diff --git a/src/Assembly.hs b/src/Assembly.hs index b67f6b26..f483257c 100644 --- a/src/Assembly.hs +++ b/src/Assembly.hs @@ -167,21 +167,21 @@ instance Pretty Instruction where Return local -> pretty local <+> "= " <> "switch" <+> pretty scrutinee - <> line - <> indent - 2 - ( vsep - [ pretty i - <+> "->" - <> line - <> indent 2 (pretty basicBlock) - | (i, basicBlock) <- branches - ] + <> line + <> indent + 2 + ( vsep + [ pretty i + <+> "->" <> line - <> "_ -> " - <> line - <> indent 2 (pretty default_) - ) + <> indent 2 (pretty basicBlock) + | (i, basicBlock) <- branches + ] + <> line + <> "_ -> " + <> line + <> indent 2 (pretty default_) + ) where voidInstr name args = name <+> hsep (pretty <$> args) @@ -197,23 +197,23 @@ instance Pretty Definition where <+> pretty type_ <+> "constant" <+> "=" - <> line - <> indent 2 (pretty knownConstant) + <> line + <> indent 2 (pretty knownConstant) ConstantDefinition type_ returnType constantParameters basicBlock -> pretty type_ <+> "constant" <+> pretty returnType <+> tupled (pretty <$> constantParameters) <+> "=" - <> line - <> indent 2 (pretty basicBlock) + <> line + <> indent 2 (pretty basicBlock) FunctionDefinition returnType args basicBlock -> "function" <+> pretty returnType <+> tupled (pretty <$> args) <+> "=" - <> line - <> indent 2 (pretty basicBlock) + <> line + <> indent 2 (pretty basicBlock) instance Pretty BasicBlock where pretty (BasicBlock instrs result) = @@ -222,7 +222,7 @@ instance Pretty BasicBlock where , pretty result ] -instance Pretty a => Pretty (Return a) where +instance (Pretty a) => Pretty (Return a) where pretty voided = case voided of Void -> "void" Return a -> pretty a diff --git a/src/AssemblyToLLVM.hs b/src/AssemblyToLLVM.hs index 245d2f9c..48a5f57c 100644 --- a/src/AssemblyToLLVM.hs +++ b/src/AssemblyToLLVM.hs @@ -102,13 +102,13 @@ llvmReturnType result = Assembly.Void -> "void" Assembly.Return type_ -> llvmType type_ -alignment :: Num a => a +alignment :: (Num a) => a alignment = 8 -wordBytes :: Num a => a +wordBytes :: (Num a) => a wordBytes = 8 -wordBits :: Num a => a +wordBits :: (Num a) => a wordBits = 64 wordSizedInt :: Builder diff --git a/src/ClosureConversion.hs b/src/ClosureConversion.hs index 1603c7ee..8048d3fe 100644 --- a/src/ClosureConversion.hs +++ b/src/ClosureConversion.hs @@ -15,7 +15,7 @@ import Telescope (Telescope) import qualified Telescope convertDefinition - :: MonadFetch Query m + :: (MonadFetch Query m) => LambdaLifted.Definition -> m ClosureConverted.Definition convertDefinition def = @@ -33,7 +33,7 @@ convertDefinition def = ClosureConverted.ParameterisedDataDefinition boxity <$> convertParameterisedDataDefinition tele convertParameterisedDataDefinition - :: MonadFetch Query m + :: (MonadFetch Query m) => Telescope Name LambdaLifted.Type LambdaLifted.ConstructorDefinitions v -> m (Telescope Name ClosureConverted.Type ClosureConverted.ConstructorDefinitions v) convertParameterisedDataDefinition tele = @@ -47,14 +47,14 @@ convertParameterisedDataDefinition tele = <*> convertParameterisedDataDefinition tele' convertTerm - :: MonadFetch Query m + :: (MonadFetch Query m) => LambdaLifted.Term v -> m (ClosureConverted.Term v) convertTerm term = convertAppliedTerm term [] convertAppliedTerm - :: MonadFetch Query m + :: (MonadFetch Query m) => LambdaLifted.Term v -> [ClosureConverted.Term v] -> m (ClosureConverted.Term v) @@ -91,7 +91,7 @@ convertAppliedTerm term args = <*> mapM convertTerm defaultBranch convertGlobal - :: MonadFetch Query m + :: (MonadFetch Query m) => Name.Lifted -> [ClosureConverted.Term v] -> m (ClosureConverted.Term v) @@ -132,7 +132,7 @@ convertGlobal global args = do LambdaLifted.DataDefinition _ tele -> functionCase tele -convertTypeDeclaration :: MonadFetch Query m => LambdaLifted.Type Void -> m (ClosureConverted.Type Void) +convertTypeDeclaration :: (MonadFetch Query m) => LambdaLifted.Type Void -> m (ClosureConverted.Type Void) convertTypeDeclaration type_ = case LambdaLifted.pisView identity type_ of Telescope.Empty _ -> @@ -141,7 +141,7 @@ convertTypeDeclaration type_ = ClosureConverted.Function <$> Telescope.hoistA convertTerm convertTerm tele convertBranches - :: MonadFetch Query m + :: (MonadFetch Query m) => LambdaLifted.Branches v -> m (ClosureConverted.Branches v) convertBranches branches = @@ -154,7 +154,7 @@ convertBranches branches = <$> OrderedHashMap.mapMUnordered convertTerm literalBranches convertTelescope - :: MonadFetch Query m + :: (MonadFetch Query m) => Telescope Name LambdaLifted.Type LambdaLifted.Term v -> m (Telescope Name ClosureConverted.Type ClosureConverted.Term v) convertTelescope tele = @@ -168,7 +168,7 @@ convertTelescope tele = <*> convertTelescope tele' applyArgs - :: Monad m + :: (Monad m) => [ClosureConverted.Term v] -> m (ClosureConverted.Term v) -> m (ClosureConverted.Term v) diff --git a/src/ClosureConverted/Readback.hs b/src/ClosureConverted/Readback.hs index fa064c1c..5c3ae891 100644 --- a/src/ClosureConverted/Readback.hs +++ b/src/ClosureConverted/Readback.hs @@ -84,7 +84,7 @@ readbackGroupedElimination env eliminee elimination = readback env branch' pure $ Syntax.Case eliminee branches' defaultBranch' -readbackGroupedSpine :: Foldable f => Domain.Environment v -> Syntax.Term v -> f Domain.GroupedElimination -> M (Syntax.Term v) +readbackGroupedSpine :: (Foldable f) => Domain.Environment v -> Syntax.Term v -> f Domain.GroupedElimination -> M (Syntax.Term v) readbackGroupedSpine = foldlM . readbackGroupedElimination diff --git a/src/ClosureConverted/Representation.hs b/src/ClosureConverted/Representation.hs index 46471e9b..ef560d9c 100644 --- a/src/ClosureConverted/Representation.hs +++ b/src/ClosureConverted/Representation.hs @@ -294,7 +294,7 @@ data Branches v | TaggedConstructorBranches !Boxity [(Int, Telescope Name Syntax.Type Syntax.Term v)] deriving (Eq, Show) -compileBranches :: MonadFetch Query m => Syntax.Branches v -> m (Branches v) +compileBranches :: (MonadFetch Query m) => Syntax.Branches v -> m (Branches v) compileBranches branches = case branches of Syntax.LiteralBranches literalBranches -> diff --git a/src/ClosureConverted/TypeOf.hs b/src/ClosureConverted/TypeOf.hs index 4fe723cf..c0eda004 100644 --- a/src/ClosureConverted/TypeOf.hs +++ b/src/ClosureConverted/TypeOf.hs @@ -112,7 +112,7 @@ typeOfHead context head = pure type' typeOfSpineApplication - :: Foldable f + :: (Foldable f) => Context v -> Domain.Type -> f Domain.Elimination diff --git a/src/ClosureConvertedToAssembly.hs b/src/ClosureConvertedToAssembly.hs index 8309de14..8e3ad6d7 100644 --- a/src/ClosureConvertedToAssembly.hs +++ b/src/ClosureConvertedToAssembly.hs @@ -83,10 +83,10 @@ emit :: Assembly.Instruction -> Builder () emit instruction = modify \s -> s {instructions = s.instructions Tsil.:> instruction} -tagBytes :: Num a => a +tagBytes :: (Num a) => a tagBytes = wordBytes -wordBytes :: Num a => a +wordBytes :: (Num a) => a wordBytes = 8 ------------------------------------------------------------------------------- @@ -503,7 +503,7 @@ forceDirect operand = ------------------------------------------------------------------------------- -pointerBytes :: Num a => a +pointerBytes :: (Num a) => a pointerBytes = 8 diff --git a/src/Command/Watch.hs b/src/Command/Watch.hs index ecfe29b5..60544af2 100644 --- a/src/Command/Watch.hs +++ b/src/Command/Watch.hs @@ -23,7 +23,7 @@ watch argumentFiles = do watcher <- FileSystem.watcherFromArguments argumentFiles signalChangeVar <- newEmptyMVar fileStateVar <- newMVar mempty - FSNotify.withManagerConf config \manager -> do + FSNotify.withManager \manager -> do stopListening <- FileSystem.runWatcher watcher manager \(changedFiles, sourceDirectories, files) -> do modifyMVar_ fileStateVar \(changedFiles', _, _) -> pure (changedFiles <> changedFiles', sourceDirectories, files) @@ -34,11 +34,6 @@ watch argumentFiles = do forever $ do (changedFiles, sourceDirectories, files) <- waitForChanges signalChangeVar fileStateVar driverState checkAndPrintErrors driverState changedFiles sourceDirectories files - where - config = - FSNotify.defaultConfig - { FSNotify.confDebounce = FSNotify.Debounce 0.010 - } waitForChanges :: MVar () diff --git a/src/Core/Domain.hs b/src/Core/Domain.hs index 20a6fe44..6dda79be 100644 --- a/src/Core/Domain.hs +++ b/src/Core/Domain.hs @@ -138,7 +138,7 @@ foldl f e spine = spine' :> elim -> f (Core.Domain.foldl f e spine') elim -foldlM :: Monad m => (a -> Elimination -> m a) -> a -> Spine -> m a +foldlM :: (Monad m) => (a -> Elimination -> m a) -> a -> Spine -> m a foldlM f e spine = case spine of Empty -> @@ -147,7 +147,7 @@ foldlM f e spine = a <- Core.Domain.foldlM f e spine' f a elim -mapM :: Monad m => (Elimination -> m a) -> Spine -> m (Tsil a) +mapM :: (Monad m) => (Elimination -> m a) -> Spine -> m (Tsil a) mapM f spine = case spine of Empty -> @@ -157,7 +157,7 @@ mapM f spine = a <- f elim pure $ as Tsil.:> a -mapM_ :: Monad m => (Elimination -> m ()) -> Spine -> m () +mapM_ :: (Monad m) => (Elimination -> m ()) -> Spine -> m () mapM_ f spine = case spine of Empty -> diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index 74ec0a42..0603b07b 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -78,7 +78,7 @@ empty = , importedAliases = mempty } -emptyM :: MonadFetch Query m => Name.Module -> m (Environment Void) +emptyM :: (MonadFetch Query m) => Name.Module -> m (Environment Void) emptyM module_ = do importedNames <- fetch $ Query.ImportedNames module_ Mapped.Map (localScope, _) <- fetch $ Query.ModuleScope module_ @@ -123,9 +123,12 @@ prettyTerm prec env term = Syntax.Pi binding type_ plicity scope -> prettyParen (prec > funPrec) $ let (env', name) = extendBinding env binding - in Plicity.prettyAnnotation plicity <> lparen <> pretty name + in Plicity.prettyAnnotation plicity + <> lparen + <> pretty name <+> ":" - <+> prettyTerm 0 env type_ <> rparen + <+> prettyTerm 0 env type_ + <> rparen <+> "->" <+> prettyTerm funPrec env' scope Syntax.Fun domain plicity target -> @@ -142,33 +145,33 @@ prettyTerm prec env term = "case" <+> prettyTerm 0 env scrutinee <+> "of" - <> line - <> indent - 2 - ( vcat $ - case branches of - Syntax.ConstructorBranches constructorTypeName constructorBranches -> - [ prettyConstr env (Name.QualifiedConstructor constructorTypeName constr) <+> prettyBranch env tele - | (constr, (_, tele)) <- OrderedHashMap.toList constructorBranches - ] - Syntax.LiteralBranches literalBranches -> - [ pretty lit <+> "->" <+> prettyTerm 0 env body - | (lit, (_, body)) <- OrderedHashMap.toList literalBranches - ] - <> [ "_" - <+> "->" - <> line - <> indent 2 (prettyTerm casePrec env branch) - | Just branch <- [defaultBranch] - ] - ) + <> line + <> indent + 2 + ( vcat $ + case branches of + Syntax.ConstructorBranches constructorTypeName constructorBranches -> + [ prettyConstr env (Name.QualifiedConstructor constructorTypeName constr) <+> prettyBranch env tele + | (constr, (_, tele)) <- OrderedHashMap.toList constructorBranches + ] + Syntax.LiteralBranches literalBranches -> + [ pretty lit <+> "->" <+> prettyTerm 0 env body + | (lit, (_, body)) <- OrderedHashMap.toList literalBranches + ] + <> [ "_" + <+> "->" + <> line + <> indent 2 (prettyTerm casePrec env branch) + | Just branch <- [defaultBranch] + ] + ) Syntax.Spanned _ term' -> prettyTerm prec env term' prettyGlobal :: Environment v -> Name.Qualified -> Doc ann prettyGlobal env global = do let aliases = - sortOn (\(Name.Surface name) -> Text.lengthWord16 name) $ + sortOn (\(Name.Surface name) -> Text.lengthWord8 name) $ filter (unambiguous env) $ HashSet.toList $ HashMap.lookupDefault mempty global $ @@ -183,7 +186,7 @@ prettyGlobal env global = do prettyConstr :: Environment v -> Name.QualifiedConstructor -> Doc ann prettyConstr env constr = do let aliases = - sortOn (\(Name.Surface name) -> Text.lengthWord16 name) $ + sortOn (\(Name.Surface name) -> Text.lengthWord8 name) $ filter (unambiguous env) $ HashSet.toList $ HashMap.lookupDefault mempty constr $ @@ -212,11 +215,13 @@ prettyLamTerm env term = case term of Syntax.Lam bindings type_ plicity scope -> let (env', name) = extendBindings env bindings - in Plicity.prettyAnnotation plicity <> lparen <> pretty name + in Plicity.prettyAnnotation plicity + <> lparen + <> pretty name <+> ":" <+> prettyTerm 0 env type_ - <> rparen - <> prettyLamTerm env' scope + <> rparen + <> prettyLamTerm env' scope Syntax.Spanned _ term' -> prettyLamTerm env term' t -> @@ -228,11 +233,12 @@ prettyPiTerm env plicity term separator = Syntax.Pi binding type_ plicity' scope | plicity == plicity' -> let (env', name) = extendBinding env binding - in lparen <> pretty name + in lparen + <> pretty name <+> ":" <+> prettyTerm 0 env type_ - <> rparen - <> prettyPiTerm env' plicity scope separator + <> rparen + <> prettyPiTerm env' plicity scope separator Syntax.Spanned _ term' -> prettyPiTerm env plicity term' separator t -> @@ -246,14 +252,14 @@ prettyLets env lets = in pretty name <+> ":" <+> prettyTerm letPrec env type_ - <> line - <> prettyLets env' lets' + <> line + <> prettyLets env' lets' Syntax.Let _ index term lets' -> prettyTerm letPrec env (Syntax.Var index) <+> "=" <+> prettyTerm letPrec env term - <> line - <> prettyLets env lets' + <> line + <> prettyLets env lets' Syntax.In term -> "in" <> line @@ -269,9 +275,12 @@ prettyBranch env tele = "->" <> line <> indent 2 (prettyTerm casePrec env body) Telescope.Extend bindings type_ plicity tele' -> let (env', name) = extendBindings env bindings - in Plicity.prettyAnnotation plicity <> "(" <> pretty name + in Plicity.prettyAnnotation plicity + <> "(" + <> pretty name <+> ":" - <+> prettyTerm 0 env type_ <> ")" + <+> prettyTerm 0 env type_ + <> ")" <+> prettyBranch env' tele' ------------------------------------------------------------------------------- @@ -306,9 +315,12 @@ prettyConstructorDefinitions env tele = "forall" <+> prettyConstructorDefinitionsImplicit env tele Telescope.Extend binding type_ plicity tele' -> let (env', name) = extendBinding env binding - in Plicity.prettyAnnotation plicity <> "(" <> pretty name + in Plicity.prettyAnnotation plicity + <> "(" + <> pretty name <+> ":" - <+> prettyTerm 0 env type_ <> ")" + <+> prettyTerm 0 env type_ + <> ")" <+> prettyConstructorDefinitions env' tele' prettyConstructorDefinitionsImplicit @@ -321,11 +333,12 @@ prettyConstructorDefinitionsImplicit env tele = prettyConstructorDefinitions env tele Telescope.Extend binding type_ Implicit tele' -> let (env', name) = extendBinding env binding - in lparen <> pretty name + in lparen + <> pretty name <+> ":" <+> prettyTerm 0 env type_ - <> rparen - <> prettyConstructorDefinitionsImplicit env' tele' + <> rparen + <> prettyConstructorDefinitionsImplicit env' tele' Telescope.Extend _ _ _ _ -> "." <+> prettyConstructorDefinitions env tele diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 3bc4e297..dedaf84a 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -67,7 +67,7 @@ implicitPi :: Binding -> Type v -> Plicity -> Scope Type v -> Type v implicitPi name type_ plicity = Pi name type_ (implicitise plicity) -apps :: Foldable f => Term v -> f (Plicity, Term v) -> Term v +apps :: (Foldable f) => Term v -> f (Plicity, Term v) -> Term v apps = foldl (\fun (plicity, arg) -> App fun plicity arg) @@ -105,7 +105,7 @@ varView term = _ -> Nothing -funs :: Foldable f => f (Term v) -> Plicity -> Term v -> Term v +funs :: (Foldable f) => f (Term v) -> Plicity -> Term v -> Term v funs args plicity res = foldr (\a b -> Fun a plicity b) res args diff --git a/src/Data/IntSeq.hs b/src/Data/IntSeq.hs index 533c8d8d..55f0b963 100644 --- a/src/Data/IntSeq.hs +++ b/src/Data/IntSeq.hs @@ -20,7 +20,7 @@ instance Semigroup (IntSeq a) where IntSeq seq1 indices1 <> IntSeq seq2 indices2 = IntSeq (seq1 <> seq2) (indices1 <> map (+ Seq.length seq1) indices2) -instance Show a => Show (IntSeq a) where +instance (Show a) => Show (IntSeq a) where showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) @@ -33,19 +33,19 @@ instance Foldable IntSeq where foldMap f (IntSeq seq _) = foldMap f seq -pattern Empty :: Enum a => IntSeq a +pattern Empty :: (Enum a) => IntSeq a pattern Empty <- IntSeq Seq.Empty _ where Empty = mempty -pattern (:>) :: Enum a => IntSeq a -> a -> IntSeq a +pattern (:>) :: (Enum a) => IntSeq a -> a -> IntSeq a pattern as :> a <- (unsnoc -> Just (as, a)) where IntSeq seq indices :> a = IntSeq (seq Seq.:|> a) (EnumMap.insert a (Seq.length seq) indices) -unsnoc :: Enum a => IntSeq a -> Maybe (IntSeq a, a) +unsnoc :: (Enum a) => IntSeq a -> Maybe (IntSeq a, a) unsnoc (IntSeq seq indices) = case seq of seq' Seq.:|> a -> @@ -58,15 +58,15 @@ length :: IntSeq a -> Int length (IntSeq seq _) = Seq.length seq -singleton :: Enum a => a -> IntSeq a +singleton :: (Enum a) => a -> IntSeq a singleton a = Empty :> a -member :: Enum a => a -> IntSeq a -> Bool +member :: (Enum a) => a -> IntSeq a -> Bool member a (IntSeq _ indices) = EnumMap.member a indices -elemIndex :: Enum a => a -> IntSeq a -> Maybe Int +elemIndex :: (Enum a) => a -> IntSeq a -> Maybe Int elemIndex a (IntSeq _ indices) = EnumMap.lookup a indices @@ -81,13 +81,13 @@ splitAt i (IntSeq seq indices) = (seq1, seq2) = Seq.splitAt i seq (indices1, indices2) = EnumMap.mapEither (\j -> if j < i then Left j else Right $ j - i) indices -insertAt :: Enum a => Int -> a -> IntSeq a -> IntSeq a +insertAt :: (Enum a) => Int -> a -> IntSeq a -> IntSeq a insertAt i a (IntSeq seq indices) = IntSeq (Seq.insertAt i a seq) (EnumMap.insert a i indices') where indices' = map (\j -> if j < i then j else j + 1) indices -delete :: Enum a => a -> IntSeq a -> IntSeq a +delete :: (Enum a) => a -> IntSeq a -> IntSeq a delete a as = case elemIndex a as of Nothing -> @@ -112,7 +112,7 @@ deleteAt i (IntSeq seq indices) = ) indices -fromTsil :: Enum a => Tsil a -> IntSeq a +fromTsil :: (Enum a) => Tsil a -> IntSeq a fromTsil tsil = case tsil of Tsil.Empty -> @@ -134,5 +134,5 @@ toTsil (IntSeq seq _) = toSeq :: IntSeq a -> Seq a toSeq (IntSeq seq _) = seq -fromSeq :: Enum a => Seq a -> IntSeq a +fromSeq :: (Enum a) => Seq a -> IntSeq a fromSeq seq = IntSeq seq $ EnumMap.fromList $ zip (toList seq) [0 ..] diff --git a/src/Data/OrderedHashMap.hs b/src/Data/OrderedHashMap.hs index 6db2198e..be2eb7b0 100644 --- a/src/Data/OrderedHashMap.hs +++ b/src/Data/OrderedHashMap.hs @@ -50,15 +50,15 @@ lookupDefault :: (Hashable k) => v -> k -> OrderedHashMap k v -> v lookupDefault def k (OrderedHashMap h) = (\(Ordered _ v) -> v) $ HashMap.lookupDefault (Ordered 0 def) k h -mapMUnordered :: Applicative f => (a -> f b) -> OrderedHashMap k a -> f (OrderedHashMap k b) +mapMUnordered :: (Applicative f) => (a -> f b) -> OrderedHashMap k a -> f (OrderedHashMap k b) mapMUnordered f (OrderedHashMap h) = OrderedHashMap <$> traverse (traverse f) h -mapMUnordered_ :: Applicative f => (a -> f ()) -> OrderedHashMap k a -> f () +mapMUnordered_ :: (Applicative f) => (a -> f ()) -> OrderedHashMap k a -> f () mapMUnordered_ f (OrderedHashMap h) = traverse_ (traverse_ f) h -forMUnordered :: Applicative f => OrderedHashMap k a -> (a -> f b) -> f (OrderedHashMap k b) +forMUnordered :: (Applicative f) => OrderedHashMap k a -> (a -> f b) -> f (OrderedHashMap k b) forMUnordered = flip mapMUnordered diff --git a/src/Data/OrderedHashSet.hs b/src/Data/OrderedHashSet.hs index 1a081a8d..cd452a52 100644 --- a/src/Data/OrderedHashSet.hs +++ b/src/Data/OrderedHashSet.hs @@ -11,7 +11,7 @@ import Prelude (Show (showsPrec), showParen, showString, shows) newtype OrderedHashSet a = OrderedHashSet (OrderedHashMap a ()) deriving (Eq, Ord, Hashable) -instance Show a => Show (OrderedHashSet a) where +instance (Show a) => Show (OrderedHashSet a) where showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) diff --git a/src/Data/Tsil.hs b/src/Data/Tsil.hs index e7e213c3..f6a61f67 100644 --- a/src/Data/Tsil.hs +++ b/src/Data/Tsil.hs @@ -15,7 +15,7 @@ data Tsil a | Tsil a :> a deriving (Eq, Functor, Ord, Traversable, Generic, Hashable) -instance Show a => Show (Tsil a) where +instance (Show a) => Show (Tsil a) where show = show . Protolude.toList instance Semigroup (Tsil a) where @@ -59,7 +59,7 @@ null :: Tsil a -> Bool null Empty = True null (_ :> _) = False -lookup :: Eq a => a -> Tsil (a, b) -> Maybe b +lookup :: (Eq a) => a -> Tsil (a, b) -> Maybe b lookup _ Empty = Nothing lookup a (as :> (a', b)) | a == a' = Just b @@ -91,10 +91,10 @@ zipWith _ Empty _ = Empty zipWith _ _ Empty = Empty zipWith f (as :> a) (bs :> b) = Data.Tsil.zipWith f as bs :> f a b -zipWithM :: Monad m => (a -> b -> m c) -> Tsil a -> Tsil b -> m (Tsil c) +zipWithM :: (Monad m) => (a -> b -> m c) -> Tsil a -> Tsil b -> m (Tsil c) zipWithM f as bs = sequenceA (Data.Tsil.zipWith f as bs) -zipWithM_ :: Monad m => (a -> b -> m c) -> Tsil a -> Tsil b -> m () +zipWithM_ :: (Monad m) => (a -> b -> m c) -> Tsil a -> Tsil b -> m () zipWithM_ f as bs = sequenceA_ (Data.Tsil.zipWith f as bs) unzip :: Tsil (a, b) -> (Tsil a, Tsil b) diff --git a/src/Driver.hs b/src/Driver.hs index 6a599484..e030fa14 100644 --- a/src/Driver.hs +++ b/src/Driver.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoFieldSelectors #-} module Driver where @@ -27,6 +28,7 @@ import Data.IORef.Lifted import qualified Data.Text.IO as Text import Data.Text.Utf16.Rope (Rope) import qualified Data.Text.Utf16.Rope as Rope +import Data.Type.Equality import Error (Error) import qualified Error.Hydrated import qualified Error.Hydrated as Error (Hydrated) @@ -273,7 +275,7 @@ pooledForConcurrently_ as f = pooledForConcurrentlyIO_ as (runInIO . f) pooledForConcurrentlyIO_ - :: Foldable t + :: (Foldable t) => t a -> (a -> IO b) -> IO () @@ -295,7 +297,7 @@ pooledForConcurrentlyIO_ as f = do replicateConcurrently_ (max 8 processCount) go pooledForConcurrentlyIO - :: Traversable t + :: (Traversable t) => t a -> (a -> IO b) -> IO (t b) diff --git a/src/Elaboration.hs b/src/Elaboration.hs index d6c5ab7f..62c2bed0 100644 --- a/src/Elaboration.hs +++ b/src/Elaboration.hs @@ -430,12 +430,12 @@ implicitLambdaResult context mode term type_ = f <- Unification.tryUnify context type' expectedType pure $ Checked $ f $ Syntax.apps term args -elaborate :: Functor result => Context v -> Surface.Term -> Mode result -> M (result (Syntax.Term v)) +elaborate :: (Functor result) => Context v -> Surface.Term -> Mode result -> M (result (Syntax.Term v)) elaborate context term@(Surface.Term span _) mode = elaborateWith (Context.spanned span context) term mode Postponement.CanPostpone elaborateWith - :: Functor result + :: (Functor result) => Context v -> Surface.Term -> Mode result @@ -676,7 +676,7 @@ data LetBoundTerm where LetBoundTerm :: Context v -> Syntax.Term v -> LetBoundTerm elaborateLets - :: Functor result + :: (Functor result) => Context v -> HashMap Name.Surface (Span.Relative, Var) -> EnumMap Var (Span.Relative, Name.Surface) diff --git a/src/Elaboration/Context.hs b/src/Elaboration/Context.hs index 6131eccb..eb22c0d9 100644 --- a/src/Elaboration/Context.hs +++ b/src/Elaboration/Context.hs @@ -81,7 +81,7 @@ toEnvironment context = , glueableBefore = Index.Zero } -empty :: MonadBase IO m => Scope.DefinitionKind -> Name.Qualified -> m (Context Void) +empty :: (MonadBase IO m) => Scope.DefinitionKind -> Name.Qualified -> m (Context Void) empty definitionKind definitionName = do ms <- newIORef Meta.empty es <- newIORef mempty diff --git a/src/Elaboration/Matching.hs b/src/Elaboration/Matching.hs index 278d59d0..1c512159 100644 --- a/src/Elaboration/Matching.hs +++ b/src/Elaboration/Matching.hs @@ -793,7 +793,7 @@ splitConstructor outerContext config scrutineeValue scrutineeHead scrutineeSpine result <- check context' config Postponement.CanPostpone pure $ Telescope.Empty result -mapWhileM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapWhileM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] mapWhileM f as = case as of [] -> pure [] diff --git a/src/Elaboration/Meta.hs b/src/Elaboration/Meta.hs index cbff27b7..bee05020 100644 --- a/src/Elaboration/Meta.hs +++ b/src/Elaboration/Meta.hs @@ -170,7 +170,7 @@ fromEagerEntry entry = EagerSolved term metas type_ -> Solved term metas type_ -toEagerEntry :: Monad m => Entry m -> m EagerEntry +toEagerEntry :: (Monad m) => Entry m -> m EagerEntry toEagerEntry entry = case entry of Unsolved type_ arity postponements span -> @@ -183,7 +183,7 @@ toEagerEntry entry = termMetas solution <> termMetas type_ pure $ EagerSolved solution mempty {direct = metas, unsolved = metas} type_ -toEagerState :: Monad m => State m -> Syntax.Definition -> Maybe (Syntax.Type Void) -> m EagerState +toEagerState :: (Monad m) => State m -> Syntax.Definition -> Maybe (Syntax.Type Void) -> m EagerState toEagerState state definition maybeType = do entries_ <- go (definitionMetas definition <> foldMap termMetas maybeType) mempty pure @@ -215,7 +215,7 @@ toEagerState state definition maybeType = do ------------------------------------------------------------------------------- -solutionMetas :: Monad m => Meta.Index -> State m -> m (Maybe CachedMetas, State m) +solutionMetas :: (Monad m) => Meta.Index -> State m -> m (Maybe CachedMetas, State m) solutionMetas metaIndex state = do case lookup metaIndex state of Unsolved {} -> diff --git a/src/Elaboration/Postponed.hs b/src/Elaboration/Postponed.hs index 1c112651..60698a62 100644 --- a/src/Elaboration/Postponed.hs +++ b/src/Elaboration/Postponed.hs @@ -39,7 +39,7 @@ update :: Postponement.Index -> Check -> Checks -> Checks update index newCheck p = p {checks = EnumMap.insert index newCheck $ checks p} -adjustF :: Functor f => (Check -> f Check) -> Postponement.Index -> Checks -> f Checks +adjustF :: (Functor f) => (Check -> f Check) -> Postponement.Index -> Checks -> f Checks adjustF adjust index p = (\checks' -> p {checks = checks'}) <$> EnumMap.alterF alter index (checks p) where diff --git a/src/Error/Hydrated.hs b/src/Error/Hydrated.hs index f4abd143..a23414af 100644 --- a/src/Error/Hydrated.hs +++ b/src/Error/Hydrated.hs @@ -27,10 +27,11 @@ import qualified Query import Rock import qualified Span import qualified System.Directory as Directory +import qualified UTF16 data Hydrated = Hydrated { filePath :: FilePath - , lineColumn :: !Span.LineColumn + , lineColumn :: !UTF16.LineColumns , lineText :: !Text , error :: !Error } @@ -53,10 +54,10 @@ headingAndBody error = (filePath, maybeOldSpan) <- fetch $ Query.DefinitionPosition definitionKind name text <- fetch $ Query.FileText filePath let (lineColumn, _) = - Position.lineColumn (fromMaybe 0 maybeOldSpan) text + UTF16.lineColumn (fromMaybe 0 maybeOldSpan) text pure ( "Duplicate name:" <+> Doc.pretty name - , Doc.pretty name <+> "has already been defined at" <+> Doc.pretty (Span.LineColumns lineColumn lineColumn) <> "." + , Doc.pretty name <+> "has already been defined at" <+> Doc.pretty (UTF16.LineColumns lineColumn lineColumn) <> "." ) Error.ImportNotFound _ import_ -> let prettyModule = Doc.pretty import_.module_ @@ -111,7 +112,7 @@ headingAndBody error = (filePath, maybeDefSpan) <- fetch $ Query.DefinitionPosition definitionKind definitionName text <- fetch $ Query.FileText filePath let (previousLineColumn, _) = - Span.lineColumn (Span.absoluteFrom (fromMaybe 0 maybeDefSpan) previousSpan) text + UTF16.lineColumns (Span.absoluteFrom (fromMaybe 0 maybeDefSpan) previousSpan) text pure ( "Duplicate name in let block:" <+> Doc.pretty name , Doc.pretty name <+> "has already been defined at" <+> Doc.pretty previousLineColumn <> "." @@ -239,31 +240,34 @@ pretty h = do filePath <- liftIO $ Directory.makeRelativeToCurrentDirectory h.filePath (heading, body) <- headingAndBody h.error pure $ - Doc.pretty filePath <> ":" <> Doc.pretty h.lineColumn <> ":" + Doc.pretty filePath + <> ":" + <> Doc.pretty h.lineColumn + <> ":" <+> heading - <> line - <> line - <> body - <> line - <> line - <> spannedLine + <> line + <> line + <> body + <> line + <> line + <> spannedLine where spannedLine = - let Span.LineColumns - (Position.LineColumn startLineNumber startColumnNumber) - (Position.LineColumn endLineNumber endColumnNumber) = h.lineColumn + let UTF16.LineColumns + (UTF16.LineColumn startLineNumber startColumnNumber) + (UTF16.LineColumn endLineNumber endColumnNumber) = h.lineColumn lineNumberText = show (startLineNumber + 1) lineNumberTextLength = - Text.lengthWord16 lineNumberText + Text.lengthWord8 lineNumberText (spanLength, spanEnding) | startLineNumber == endLineNumber = (endColumnNumber - startColumnNumber, mempty) | otherwise = - (Text.lengthWord16 h.lineText - startColumnNumber, "...") + (UTF16.length h.lineText - startColumnNumber, "...") in Doc.pretty (Text.replicate (lineNumberTextLength + 1) " ") <> "| " <> line @@ -273,7 +277,7 @@ pretty h = do <> line <> Doc.pretty (Text.replicate (lineNumberTextLength + 1) " ") <> "| " - <> Doc.pretty (Text.replicate startColumnNumber " " <> "^" <> Text.replicate (spanLength - 1) "~" <> spanEnding) + <> Doc.pretty (Text.replicate (UTF16.toInt startColumnNumber) " " <> "^" <> Text.replicate (UTF16.toInt spanLength - 1) "~" <> spanEnding) fromError :: Error -> Task Query Hydrated fromError err = do @@ -302,10 +306,10 @@ fromError err = do case eofOrSpan of Left Error.Parsing.EOF -> do let eofPos = - Position.Absolute $ Text.lengthWord16 text - Span.lineColumn (Span.Absolute eofPos eofPos) text + Position.Absolute $ Text.lengthWord8 text + UTF16.lineColumns (Span.Absolute eofPos eofPos) text Right span -> - Span.lineColumn span text + UTF16.lineColumns span text pure Hydrated { filePath = filePath @@ -319,9 +323,9 @@ fromError err = do lineNumber :: Hydrated -> Int lineNumber err = l where - Span.LineColumns (Position.LineColumn l _) _ = err.lineColumn + UTF16.LineColumns (UTF16.LineColumn l _) _ = err.lineColumn -prettyPrettyableTerm :: MonadFetch Query m => Int -> Error.PrettyableTerm -> m (Doc ann) +prettyPrettyableTerm :: (MonadFetch Query m) => Int -> Error.PrettyableTerm -> m (Doc ann) prettyPrettyableTerm prec (Error.PrettyableTerm moduleName_ names term) = do env <- Pretty.emptyM moduleName_ pure $ go names env @@ -336,7 +340,7 @@ prettyPrettyableTerm prec (Error.PrettyableTerm moduleName_ names term) = do Pretty.extend env' name in go names'' env'' -prettyPrettyablePattern :: MonadFetch Query m => Int -> (Plicity, Error.PrettyablePattern) -> m (Doc ann) +prettyPrettyablePattern :: (MonadFetch Query m) => Int -> (Plicity, Error.PrettyablePattern) -> m (Doc ann) prettyPrettyablePattern prec (plicity, Error.PrettyablePattern moduleName_ names pattern_) = do env <- Pretty.emptyM moduleName_ pure $ go names env diff --git a/src/Extra.hs b/src/Extra.hs index ed2c9ae7..207892c1 100644 --- a/src/Extra.hs +++ b/src/Extra.hs @@ -38,7 +38,7 @@ last = go (Just a) as' {-# INLINE defaultHashWithSalt #-} -defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt :: (Hashable a) => Int -> a -> Int defaultHashWithSalt salt x = salt `combine` hash x where diff --git a/src/FileSystem.hs b/src/FileSystem.hs index 21552a3e..781c64d6 100644 --- a/src/FileSystem.hs +++ b/src/FileSystem.hs @@ -29,7 +29,7 @@ newtype Watcher a = Watcher } deriving (Functor) -instance Monoid a => Semigroup (Watcher a) where +instance (Monoid a) => Semigroup (Watcher a) where Watcher watcher1 <> Watcher watcher2 = Watcher \manager onChange -> do valuesVar <- newMVar mempty @@ -43,7 +43,7 @@ instance Monoid a => Semigroup (Watcher a) where onChange value pure $ stopListening1 <> stopListening2 -instance Monoid a => Monoid (Watcher a) where +instance (Monoid a) => Monoid (Watcher a) where mempty = Watcher mempty @@ -183,7 +183,7 @@ fileWatcher filePath = Watcher \manager onChange -> do onChange maybeText ) -jsonFileWatcher :: Aeson.FromJSON a => FilePath -> Watcher (Maybe a) +jsonFileWatcher :: (Aeson.FromJSON a) => FilePath -> Watcher (Maybe a) jsonFileWatcher filePath = Watcher \manager onChange -> do maybeOriginalValue <- readFileJSON filePath onChange maybeOriginalValue @@ -239,7 +239,7 @@ readFileText file = `catch` \(_ :: IOException) -> pure Nothing -readFileJSON :: Aeson.FromJSON a => FilePath -> IO (Maybe a) +readFileJSON :: (Aeson.FromJSON a) => FilePath -> IO (Maybe a) readFileJSON file = Aeson.decodeFileStrict file `catch` \(_ :: IOException) -> diff --git a/src/Index/Map.hs b/src/Index/Map.hs index 13a6b6d2..d57c294c 100644 --- a/src/Index/Map.hs +++ b/src/Index/Map.hs @@ -13,10 +13,10 @@ import Protolude hiding (Map) newtype Map v a = Map (IntSeq a) deriving (Show, Foldable) -pattern Empty :: Enum a => Map Void a +pattern Empty :: (Enum a) => Map Void a pattern Empty = Map IntSeq.Empty -pattern (:>) :: Enum a => Map v a -> a -> Map (Succ v) a +pattern (:>) :: (Enum a) => Map v a -> a -> Map (Succ v) a pattern as :> a <- Map ((Map -> as) IntSeq.:> a) where @@ -27,7 +27,7 @@ pattern as :> a <- length :: Map v a -> Index (Succ v) length (Map m) = Index $ IntSeq.length m -elemIndex :: Enum a => a -> Map v a -> Maybe (Index v) +elemIndex :: (Enum a) => a -> Map v a -> Maybe (Index v) elemIndex a (Map m) = (\i -> Index $ IntSeq.length m - i - 1) <$> IntSeq.elemIndex a m diff --git a/src/LambdaLifting.hs b/src/LambdaLifting.hs index c2fa3eb7..bf16d8da 100644 --- a/src/LambdaLifting.hs +++ b/src/LambdaLifting.hs @@ -132,7 +132,7 @@ makeApp fun arg = occurrences fun <> occurrences arg -makeApps :: Foldable f => Value -> f Value -> Value +makeApps :: (Foldable f) => Value -> f Value -> Value makeApps = foldl makeApp diff --git a/src/LanguageServer.hs b/src/LanguageServer.hs index 6fd10818..0dc4cb11 100644 --- a/src/LanguageServer.hs +++ b/src/LanguageServer.hs @@ -18,17 +18,16 @@ import qualified Data.HashMap.Lazy as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import qualified Data.Map as Map -import Data.Text.Utf16.Rope (Rope) -import qualified Data.Text.Utf16.Rope as Rope import qualified Driver import qualified Error.Hydrated import qualified Error.Hydrated as Error (Hydrated) import qualified FileSystem import qualified Language.LSP.Diagnostics as LSP +import qualified Language.LSP.Protocol.Lens as LSP hiding (rootPath) +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import qualified Language.LSP.Server as LSP.Server -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Lens as LSP hiding (rootPath) import qualified Language.LSP.VFS as LSP import qualified LanguageServer.CodeLens as CodeLens import qualified LanguageServer.Completion as Completion @@ -37,16 +36,15 @@ import qualified LanguageServer.GoToDefinition as GoToDefinition import qualified LanguageServer.Hover as Hover import qualified LanguageServer.References as References import qualified Occurrences.Intervals -import qualified Position import Prettyprinter (Doc) import qualified Prettyprinter as Doc import qualified Project import Protolude hiding (State, state) import Query (Query) import Rock (Task) -import qualified Span import qualified System.Directory as Directory import qualified System.FSNotify as FSNotify +import qualified UTF16 run :: IO () run = do @@ -58,7 +56,6 @@ run = do LSP.runServer LSP.ServerDefinition { LSP.defaultConfig = () - , LSP.onConfigurationChange = \_ _ -> Right () , LSP.doInitialize = \env _req -> do case LSP.resRootPath env of Nothing -> pure () @@ -66,7 +63,7 @@ run = do maybeProjectFile <- Project.findProjectFile rootPath forM_ maybeProjectFile \projectFile -> do projectFile' <- Directory.canonicalizePath projectFile - FSNotify.withManagerConf config \manager -> do + FSNotify.withManager \manager -> do stopListening <- FileSystem.runWatcher (FileSystem.projectWatcher projectFile') manager \(changedFiles, sourceDirectories, diskFiles) -> do modifyMVar_ diskFileStateVar \(changedFiles', _, _) -> pure (changedFiles <> changedFiles', sourceDirectories, diskFiles) @@ -88,54 +85,52 @@ run = do } _ <- forkIO $ messagePump state pure $ Right () - , staticHandlers = handlers $ atomically . writeTQueue messageQueue + , staticHandlers = \_clientCapabilities -> handlers $ atomically . writeTQueue messageQueue , options , interpretHandler = \() -> LSP.Iso identity identity + , configSection = "sixten" + , parseConfig = \() _ -> Right () + , onConfigChange = pure } `finally` do join $ swapMVar stopListeningVar mempty pure () - where - config = - FSNotify.defaultConfig - { FSNotify.confDebounce = FSNotify.Debounce 0.010 - } handlers :: (ReceivedMessage -> IO ()) -> LSP.Handlers IO handlers onReceivedMessage = mconcat - [ LSP.notificationHandler LSP.STextDocumentDidOpen $ onReceivedMessage . ReceivedNotification - , LSP.notificationHandler LSP.STextDocumentDidChange $ onReceivedMessage . ReceivedNotification - , LSP.notificationHandler LSP.STextDocumentDidSave $ onReceivedMessage . ReceivedNotification - , LSP.notificationHandler LSP.STextDocumentDidClose $ onReceivedMessage . ReceivedNotification - , LSP.requestHandler LSP.STextDocumentHover \req -> onReceivedMessage . ReceivedRequest req - , LSP.requestHandler LSP.STextDocumentDefinition \req -> onReceivedMessage . ReceivedRequest req - , LSP.requestHandler LSP.STextDocumentCompletion \req -> onReceivedMessage . ReceivedRequest req - , LSP.requestHandler LSP.STextDocumentDocumentHighlight \req -> onReceivedMessage . ReceivedRequest req - , LSP.requestHandler LSP.STextDocumentReferences \req -> onReceivedMessage . ReceivedRequest req - , LSP.requestHandler LSP.STextDocumentRename \req -> onReceivedMessage . ReceivedRequest req - , LSP.requestHandler LSP.STextDocumentCodeLens \req -> onReceivedMessage . ReceivedRequest req + [ LSP.notificationHandler LSP.SMethod_TextDocumentDidOpen $ onReceivedMessage . ReceivedNotification + , LSP.notificationHandler LSP.SMethod_TextDocumentDidChange $ onReceivedMessage . ReceivedNotification + , LSP.notificationHandler LSP.SMethod_TextDocumentDidSave $ onReceivedMessage . ReceivedNotification + , LSP.notificationHandler LSP.SMethod_TextDocumentDidClose $ onReceivedMessage . ReceivedNotification + , LSP.requestHandler LSP.SMethod_TextDocumentHover \req -> onReceivedMessage . ReceivedRequest req + , LSP.requestHandler LSP.SMethod_TextDocumentDefinition \req -> onReceivedMessage . ReceivedRequest req + , LSP.requestHandler LSP.SMethod_TextDocumentCompletion \req -> onReceivedMessage . ReceivedRequest req + , LSP.requestHandler LSP.SMethod_TextDocumentDocumentHighlight \req -> onReceivedMessage . ReceivedRequest req + , LSP.requestHandler LSP.SMethod_TextDocumentReferences \req -> onReceivedMessage . ReceivedRequest req + , LSP.requestHandler LSP.SMethod_TextDocumentRename \req -> onReceivedMessage . ReceivedRequest req + , LSP.requestHandler LSP.SMethod_TextDocumentCodeLens \req -> onReceivedMessage . ReceivedRequest req ] options :: LSP.Options options = def - { LSP.Server.textDocumentSync = + { LSP.Server.optTextDocumentSync = Just LSP.TextDocumentSyncOptions { LSP._openClose = Just True - , LSP._change = Just LSP.TdSyncIncremental + , LSP._change = Just LSP.TextDocumentSyncKind_Incremental , LSP._willSave = Just False , LSP._willSaveWaitUntil = Just False , LSP._save = Just $ LSP.InR $ LSP.SaveOptions {_includeText = Just False} } - , LSP.completionTriggerCharacters = Just "?" + , LSP.optCompletionTriggerCharacters = Just "?" } data ReceivedMessage where - ReceivedRequest :: LSP.RequestMessage m -> (Either LSP.ResponseError (LSP.ResponseResult m) -> IO ()) -> ReceivedMessage - ReceivedNotification :: LSP.NotificationMessage m -> ReceivedMessage + ReceivedRequest :: LSP.TRequestMessage m -> (Either LSP.ResponseError (LSP.MessageResult m) -> IO ()) -> ReceivedMessage + ReceivedNotification :: LSP.TNotificationMessage m -> ReceivedMessage data State = State { env :: !(LSP.LanguageContextEnv ()) @@ -177,7 +172,7 @@ messagePump state = do onMessage :: (State -> IO k) -> ReceivedMessage -> IO k onMessage k (ReceivedNotification message) = case message ^. LSP.method of - LSP.STextDocumentDidOpen -> do + LSP.SMethod_TextDocumentDidOpen -> do let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri filePath <- Directory.canonicalizePath $ uriToFilePath uri @@ -185,7 +180,7 @@ messagePump state = do state { changedFiles = HashSet.insert filePath state.changedFiles } - LSP.STextDocumentDidChange -> do + LSP.SMethod_TextDocumentDidChange -> do let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri filePath <- Directory.canonicalizePath $ uriToFilePath uri @@ -193,7 +188,7 @@ messagePump state = do state { changedFiles = HashSet.insert filePath state.changedFiles } - LSP.STextDocumentDidSave -> do + LSP.SMethod_TextDocumentDidSave -> do let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri filePath <- Directory.canonicalizePath $ uriToFilePath uri @@ -201,7 +196,7 @@ messagePump state = do state { changedFiles = HashSet.insert filePath state.changedFiles } - LSP.STextDocumentDidClose -> do + LSP.SMethod_TextDocumentDidClose -> do let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri filePath <- Directory.canonicalizePath $ uriToFilePath uri @@ -213,7 +208,7 @@ messagePump state = do k state onMessage k (ReceivedRequest message respond) = case message ^. LSP.method of - LSP.STextDocumentHover -> do + LSP.SMethod_TextDocumentHover -> do sendNotification state $ "messagePump: HoverRequest: " <> show message let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -228,17 +223,17 @@ messagePump state = do \(span, doc) -> LSP.Hover { _contents = - LSP.HoverContents + LSP.InL LSP.MarkupContent - { _kind = LSP.MkPlainText + { _kind = LSP.MarkupKind_PlainText , _value = show doc } , _range = Just $ spanToRange span } - respond $ Right response + respond $ Right $ LSP.maybeToNull response k state - LSP.STextDocumentDefinition -> do + LSP.SMethod_TextDocumentDefinition -> do sendNotification state $ "messagePump: DefinitionRequest: " <> show message let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -252,11 +247,15 @@ messagePump state = do Nothing -> respond $ Left - LSP.ResponseError {_code = LSP.UnknownErrorCode, _message = "Couldn't find a definition to jump to under the cursor", _xdata = Nothing} + LSP.ResponseError + { _code = LSP.InR LSP.ErrorCodes_UnknownErrorCode + , _message = "Couldn't find a definition to jump to under the cursor" + , _xdata = Nothing + } Just (file, span) -> - respond $ Right $ LSP.InL $ spanToLocation file span + respond $ Right $ LSP.InL $ LSP.Definition $ LSP.InL $ spanToLocation file span k state - LSP.STextDocumentCompletion -> do + LSP.SMethod_TextDocumentCompletion -> do sendNotification state $ "messagePump: CompletionRequest: " <> show message let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -266,7 +265,7 @@ messagePump state = do (completions, _) <- runTask state Driver.Don'tPrune $ case maybeContext of - Just (LSP.CompletionContext LSP.CtTriggerCharacter (Just "?")) -> + Just (LSP.CompletionContext LSP.CompletionTriggerKind_TriggerCharacter (Just "?")) -> Completion.questionMark (uriToFilePath uri) (positionFromPosition position) _ -> Completion.complete (uriToFilePath uri) (positionFromPosition position) @@ -276,12 +275,13 @@ messagePump state = do let response = LSP.CompletionList { LSP._isIncomplete = False - , LSP._items = LSP.List $ fold completions + , LSP._itemDefaults = Nothing + , LSP._items = fold completions } - respond $ Right $ LSP.InR response + respond $ Right $ LSP.InR $ LSP.InL response k state - LSP.STextDocumentDocumentHighlight -> do + LSP.SMethod_TextDocumentDocumentHighlight -> do sendNotification state $ "messagePump: document highlights request: " <> show message let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -292,18 +292,17 @@ messagePump state = do DocumentHighlights.highlights (uriToFilePath uri) (positionFromPosition position) let response = - LSP.List - [ LSP.DocumentHighlight - { _range = spanToRange span - , _kind = Just LSP.HkRead - } - | span <- highlights - ] + [ LSP.DocumentHighlight + { _range = spanToRange span + , _kind = Just LSP.DocumentHighlightKind_Read + } + | span <- highlights + ] sendNotification state $ "messagePump: document highlights response: " <> show highlights - respond $ Right response + respond $ Right $ LSP.InL response k state - LSP.STextDocumentReferences -> do + LSP.SMethod_TextDocumentReferences -> do sendNotification state $ "messagePump: references request: " <> show message let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -314,19 +313,18 @@ messagePump state = do References.references (uriToFilePath uri) (positionFromPosition position) let response = - LSP.List - [ LSP.Location - { _uri = LSP.filePathToUri filePath - , _range = spanToRange span - } - | (_item, references') <- references - , (filePath, span) <- references' - ] + [ LSP.Location + { _uri = LSP.filePathToUri filePath + , _range = spanToRange span + } + | (_item, references') <- references + , (filePath, span) <- references' + ] sendNotification state $ "messagePump: references response: " <> show response - respond $ Right response + respond $ Right $ LSP.InL response k state - LSP.STextDocumentRename -> do + LSP.SMethod_TextDocumentRename -> do sendNotification state $ "messagePump: rename request: " <> show message let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -341,15 +339,15 @@ messagePump state = do LSP.WorkspaceEdit { _changes = Just $ - HashMap.fromListWith + Map.fromListWith (<>) [ ( LSP.filePathToUri filePath - , LSP.List - [ LSP.TextEdit - { _range = spanToRange $ Occurrences.Intervals.nameSpan item span - , _newText = newName - } - ] + , + [ LSP.TextEdit + { _range = spanToRange $ Occurrences.Intervals.nameSpan item span + , _newText = newName + } + ] ) | (item, references') <- references , (filePath, span) <- references' @@ -359,9 +357,9 @@ messagePump state = do } sendNotification state $ "messagePump: rename response: " <> show references - respond $ Right response + respond $ Right $ LSP.InL response k state - LSP.STextDocumentCodeLens -> do + LSP.SMethod_TextDocumentCodeLens -> do let document = message ^. LSP.params . LSP.textDocument uri = document ^. LSP.uri @@ -370,21 +368,20 @@ messagePump state = do CodeLens.codeLens $ uriToFilePath uri let response = - LSP.List - [ LSP.CodeLens - { _range = spanToRange span - , _command = - Just - LSP.Command - { _title = show doc - , _command = "" - , _arguments = Nothing - } - , _xdata = Nothing - } - | (span, doc) <- codeLenses - ] - respond $ Right response + [ LSP.CodeLens + { _range = spanToRange span + , _command = + Just + LSP.Command + { _title = show doc + , _command = "" + , _arguments = Nothing + } + , _data_ = Nothing + } + | (span, doc) <- codeLenses + ] + respond $ Right $ LSP.InL response k state _ -> k state @@ -442,73 +439,60 @@ sendNotification state s = LSP.runLspT state.env $ LSP.sendNotification - LSP.SWindowLogMessage - LSP.LogMessageParams {_xtype = LSP.MtInfo, _message = s} + LSP.SMethod_WindowLogMessage + LSP.LogMessageParams {_type_ = LSP.MessageType_Info, _message = s} + +type TextDocumentVersion = Int32 -publishDiagnostics :: State -> LSP.NormalizedUri -> LSP.TextDocumentVersion -> [LSP.Diagnostic] -> IO () +publishDiagnostics :: State -> LSP.NormalizedUri -> TextDocumentVersion -> [LSP.Diagnostic] -> IO () publishDiagnostics state uri version diagnostics = LSP.runLspT state.env $ - LSP.Server.publishDiagnostics maxDiagnostics uri version (LSP.partitionBySource diagnostics) + LSP.Server.publishDiagnostics maxDiagnostics uri (Just version) (LSP.partitionBySource diagnostics) where maxDiagnostics = 100 -diagnosticSource :: LSP.DiagnosticSource +diagnosticSource :: Text diagnosticSource = "sixten" errorToDiagnostic :: Error.Hydrated -> Doc ann -> LSP.Diagnostic errorToDiagnostic err doc = LSP.Diagnostic { _range = spanToRange err.lineColumn - , _severity = Just LSP.DsError + , _severity = Just LSP.DiagnosticSeverity_Error , _code = Nothing , _source = Just diagnosticSource , _message = show doc , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } -spanToLocation :: FilePath -> Span.LineColumn -> LSP.Location +spanToLocation :: FilePath -> UTF16.LineColumns -> LSP.Location spanToLocation filePath span = LSP.Location { _uri = LSP.filePathToUri filePath , _range = spanToRange span } -spanToRange :: Span.LineColumn -> LSP.Range -spanToRange (Span.LineColumns start end) = +spanToRange :: UTF16.LineColumns -> LSP.Range +spanToRange (UTF16.LineColumns start end) = LSP.Range { _start = positionToPosition start , _end = positionToPosition end } -positionToPosition :: Position.LineColumn -> LSP.Position -positionToPosition (Position.LineColumn line column) = +positionToPosition :: UTF16.LineColumn -> LSP.Position +positionToPosition (UTF16.LineColumn line column) = LSP.Position { _line = fromIntegral line - , _character = fromIntegral column + , _character = fromIntegral $ UTF16.toInt column } -positionFromPosition :: LSP.Position -> Position.LineColumn +positionFromPosition :: LSP.Position -> UTF16.LineColumn positionFromPosition (LSP.Position line column) = - Position.LineColumn (fromIntegral line) (fromIntegral column) + UTF16.LineColumn (fromIntegral line) (UTF16.CodeUnits $ fromIntegral column) uriToFilePath :: LSP.Uri -> FilePath uriToFilePath = fromMaybe "" . LSP.uriToFilePath - -applyChanges :: Rope -> [LSP.TextDocumentContentChangeEvent] -> Rope -applyChanges = foldl' applyChange - -applyChange :: Rope -> LSP.TextDocumentContentChangeEvent -> Rope -applyChange _ (LSP.TextDocumentContentChangeEvent Nothing _ str) = - Rope.fromText str -applyChange str (LSP.TextDocumentContentChangeEvent (Just (LSP.Range (LSP.Position sl sc) (LSP.Position fl fc))) _ txt) = - changeChars str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt - -changeChars :: Rope -> Rope.Position -> Rope.Position -> Text -> Rope -changeChars str start finish new = do - case Rope.splitAtPosition finish str of - Nothing -> panic "split inside code point" - Just (before, after) -> case Rope.splitAtPosition start before of - Nothing -> panic "split inside code point" - Just (before', _) -> mconcat [before', Rope.fromText new, after] diff --git a/src/LanguageServer/CodeLens.hs b/src/LanguageServer/CodeLens.hs index 65472f15..eb9a867c 100644 --- a/src/LanguageServer/CodeLens.hs +++ b/src/LanguageServer/CodeLens.hs @@ -19,8 +19,9 @@ import Rock import qualified Scope import qualified Span import qualified Surface.Syntax as Surface +import qualified UTF16 -codeLens :: FilePath -> Task Query [(Span.LineColumn, Doc ann)] +codeLens :: FilePath -> Task Query [(UTF16.LineColumns, Doc ann)] codeLens filePath = runM $ do (moduleName, _, defs) <- fetch $ Query.ParsedFile filePath @@ -39,7 +40,7 @@ codeLens filePath = prettyType <- Error.prettyPrettyableTerm 0 =<< Context.toPrettyableTerm context type_ pure [ - ( toLineColumns $ Span.Absolute pos $ pos + Position.Absolute (Text.lengthWord16 nameText) + ( toLineColumns $ Span.Absolute pos $ pos + Position.Absolute (Text.lengthWord8 nameText) , prettyType ) ] diff --git a/src/LanguageServer/Completion.hs b/src/LanguageServer/Completion.hs index aa2cde2c..c18d08da 100644 --- a/src/LanguageServer/Completion.hs +++ b/src/LanguageServer/Completion.hs @@ -20,13 +20,12 @@ import qualified Elaboration import Elaboration.Context (Context) import qualified Elaboration.Context as Context import qualified Error.Hydrated as Error -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Types as LSP import qualified LanguageServer.CursorAction as CursorAction import Monad import Name (Name (Name)) import qualified Name import Plicity -import qualified Position import Prettyprinter ((<+>)) import Protolude hiding (catch, evaluate, moduleName) import Query (Query) @@ -34,11 +33,13 @@ import qualified Query import qualified Query.Mapped as Mapped import Rock import qualified Scope +import qualified UTF16 import Var (Var) -complete :: FilePath -> Position.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) -complete filePath (Position.LineColumn line column) = - CursorAction.cursorAction filePath (Position.LineColumn line $ max 0 $ column - 1) \item _ -> +complete :: FilePath -> UTF16.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) +complete filePath (UTF16.LineColumn line column) = + -- TODO needs to work on code points, not code units + CursorAction.cursorAction filePath (UTF16.LineColumn line $ max 0 $ column - 1) \item _ -> case item of CursorAction.Import _ -> empty @@ -52,6 +53,7 @@ complete filePath (Position.LineColumn line column) = pure LSP.CompletionItem { _label = name + , _labelDetails = Nothing , _kind = Just kind , _detail = Just $ show $ ":" <+> prettyType , _documentation = Nothing @@ -63,16 +65,18 @@ complete filePath (Position.LineColumn line column) = , _insertTextFormat = Nothing , _insertTextMode = Nothing , _textEdit = Nothing + , _textEditText = Nothing , _additionalTextEdits = Nothing , _commitCharacters = Nothing , _command = Nothing - , _xdata = Nothing , _tags = mempty + , _data_ = Nothing } -questionMark :: FilePath -> Position.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) -questionMark filePath (Position.LineColumn line column) = - CursorAction.cursorAction filePath (Position.LineColumn line $ max 0 $ column - 1) \item _ -> +questionMark :: FilePath -> UTF16.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) +questionMark filePath (UTF16.LineColumn line column) = + -- TODO needs to work on code points, not code units + CursorAction.cursorAction filePath (UTF16.LineColumn line $ max 0 $ column - 1) \item _ -> case item of CursorAction.Import _ -> empty @@ -118,6 +122,7 @@ questionMark filePath (Position.LineColumn line column) = pure LSP.CompletionItem { _label = name + , _labelDetails = Nothing , _kind = Just kind , _detail = Just $ show $ ":" <+> prettyTypeUnderCursor , _documentation = Nothing @@ -126,23 +131,24 @@ questionMark filePath (Position.LineColumn line column) = , _sortText = Nothing , _filterText = Nothing , _insertText = Nothing - , _insertTextFormat = Just LSP.Snippet + , _insertTextFormat = Just LSP.InsertTextFormat_Snippet , _insertTextMode = Nothing , _textEdit = Just $ - LSP.CompletionEditText + LSP.InL LSP.TextEdit { _range = LSP.Range { _start = LSP.Position { _line = fromIntegral line - , _character = fromIntegral $ column - 1 + , -- TODO needs to work with code points + _character = fromIntegral $ UTF16.toInt $ column - 1 } , _end = LSP.Position { _line = fromIntegral line - , _character = fromIntegral column + , _character = fromIntegral $ UTF16.toInt column } } , _newText = @@ -154,11 +160,12 @@ questionMark filePath (Position.LineColumn line column) = ] <> (if null explicitArgs then "" else ")") } + , _textEditText = Nothing , _additionalTextEdits = Nothing , _commitCharacters = Nothing , _command = Nothing - , _xdata = Nothing , _tags = mempty + , _data_ = Nothing } getUsableNames :: CursorAction.ItemContext -> Context v -> EnumMap Var value -> M [(Text, Domain.Value, LSP.CompletionItemKind)] @@ -169,7 +176,7 @@ getUsableNames itemContext context varPositions = do forM (EnumMap.toList varPositions) \(var, _) -> do let Name text = Context.lookupVarName var context - pure (text, Domain.var var, LSP.CiVariable) + pure (text, Domain.var var, LSP.CompletionItemKind_Variable) CursorAction.PatternContext -> pure [] CursorAction.DefinitionContext -> @@ -191,9 +198,9 @@ getUsableNames itemContext context varPositions = do ( name , Domain.global global , case definition of - Syntax.DataDefinition {} -> LSP.CiEnum - Syntax.ConstantDefinition {} -> LSP.CiConstant - Syntax.TypeDeclaration {} -> LSP.CiConstant + Syntax.DataDefinition {} -> LSP.CompletionItemKind_Enum + Syntax.ConstantDefinition {} -> LSP.CompletionItemKind_Constant + Syntax.TypeDeclaration {} -> LSP.CompletionItemKind_Constant ) ] case itemContext of @@ -208,10 +215,10 @@ getUsableNames itemContext context varPositions = do pure $ case toList datas of [data_] -> - [(name, Domain.global data_, LSP.CiEnum)] + [(name, Domain.global data_, LSP.CompletionItemKind_Enum)] _ -> [] - <> [ (name, Domain.con con, LSP.CiEnumMember) + <> [ (name, Domain.con con, LSP.CompletionItemKind_EnumMember) | con <- toList constrs ] case itemContext of diff --git a/src/LanguageServer/CursorAction.hs b/src/LanguageServer/CursorAction.hs index fc9d428c..6f706b24 100644 --- a/src/LanguageServer/CursorAction.hs +++ b/src/LanguageServer/CursorAction.hs @@ -46,9 +46,10 @@ import qualified Scope import qualified Span import Telescope (Telescope) import qualified Telescope +import qualified UTF16 import Var (Var) -type Callback a = ItemUnderCursor -> Span.LineColumn -> MaybeT M a +type Callback a = ItemUnderCursor -> UTF16.LineColumns -> MaybeT M a data ItemUnderCursor where Term @@ -70,22 +71,20 @@ data ItemContext cursorAction :: forall a . FilePath - -> Position.LineColumn + -> UTF16.LineColumn -> Callback a -> Task Query (Maybe a) -cursorAction filePath (Position.LineColumn line column) k = +cursorAction filePath (UTF16.LineColumn line column) k = runM $ runMaybeT $ do (moduleName, moduleHeader, _) <- fetch $ Query.ParsedFile filePath spans <- fetch $ Query.ModuleSpanMap moduleName - contents <- fetch $ Query.FileText filePath - let - -- TODO use the rope that we get from the LSP library instead - pos = - Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) $ Rope.fromText contents of - Nothing -> 0 - Just (rope, _) -> fromIntegral $ Rope.length rope + contents <- fetch $ Query.FileRope filePath + let pos = + Position.Absolute $ + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of + Nothing -> 0 + Just (rope, _) -> fromIntegral $ Rope.utf8Length rope toLineColumns <- LineColumns.fromAbsolute moduleName asum $ diff --git a/src/LanguageServer/DocumentHighlights.hs b/src/LanguageServer/DocumentHighlights.hs index aa201a5d..b5294854 100644 --- a/src/LanguageServer/DocumentHighlights.hs +++ b/src/LanguageServer/DocumentHighlights.hs @@ -14,22 +14,21 @@ import Query (Query) import qualified Query import Rock import qualified Span +import qualified UTF16 highlights :: FilePath - -> Position.LineColumn - -> Task Query [Span.LineColumn] -highlights filePath (Position.LineColumn line column) = do + -> UTF16.LineColumn + -> Task Query [UTF16.LineColumns] +highlights filePath (UTF16.LineColumn line column) = do (moduleName, _, _) <- fetch $ Query.ParsedFile filePath spans <- fetch $ Query.ModuleSpanMap moduleName - contents <- fetch $ Query.FileText filePath - let - -- TODO use the rope that we get from the LSP library instead - pos = - Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) $ Rope.fromText contents of - Nothing -> 0 - Just (rope, _) -> fromIntegral $ Rope.length rope + contents <- fetch $ Query.FileRope filePath + let pos = + Position.Absolute $ + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of + Nothing -> 0 + Just (rope, _) -> fromIntegral $ Rope.utf8Length rope toLineColumns <- LineColumns.fromAbsolute moduleName diff --git a/src/LanguageServer/GoToDefinition.hs b/src/LanguageServer/GoToDefinition.hs index ec0fc910..db777729 100644 --- a/src/LanguageServer/GoToDefinition.hs +++ b/src/LanguageServer/GoToDefinition.hs @@ -20,17 +20,18 @@ import qualified Query import Rock import qualified Scope import qualified Span +import qualified UTF16 -goToDefinition :: FilePath -> Position.LineColumn -> Task Query (Maybe (FilePath, Span.LineColumn)) -goToDefinition filePath (Position.LineColumn line column) = do +goToDefinition :: FilePath -> UTF16.LineColumn -> Task Query (Maybe (FilePath, UTF16.LineColumns)) +goToDefinition filePath (UTF16.LineColumn line column) = do (moduleName, moduleHeader, _) <- fetch $ Query.ParsedFile filePath spans <- fetch $ Query.ModuleSpanMap moduleName rope <- fetch $ Query.FileRope filePath let pos = Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) rope of + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) rope of Nothing -> 0 - Just (rope', _) -> fromIntegral $ Rope.length rope' + Just (rope', _) -> fromIntegral $ Rope.utf8Length rope' runMaybeT $ asum $ @@ -44,7 +45,7 @@ goToDefinition filePath (Position.LineColumn line column) = do Nothing -> empty Just definingFile -> - pure (definingFile, Span.LineColumns (Position.LineColumn 0 0) (Position.LineColumn 0 0)) + pure (definingFile, UTF16.LineColumns (UTF16.LineColumn 0 0) (UTF16.LineColumn 0 0)) ) <> foreach (HashMap.toList spans) diff --git a/src/LanguageServer/Hover.hs b/src/LanguageServer/Hover.hs index fd4d6f6a..39da1db7 100644 --- a/src/LanguageServer/Hover.hs +++ b/src/LanguageServer/Hover.hs @@ -9,14 +9,13 @@ import qualified Elaboration import qualified Elaboration.Context as Context import qualified Error.Hydrated as Error import qualified LanguageServer.CursorAction as CursorAction -import qualified Position import Prettyprinter (Doc, (<+>)) import Protolude hiding (evaluate, moduleName) import Query (Query) import Rock -import qualified Span +import qualified UTF16 -hover :: FilePath -> Position.LineColumn -> Task Query (Maybe (Span.LineColumn, Doc ann)) +hover :: FilePath -> UTF16.LineColumn -> Task Query (Maybe (UTF16.LineColumns, Doc ann)) hover filePath pos = CursorAction.cursorAction filePath pos \item lineColumn -> case item of diff --git a/src/LanguageServer/LineColumns.hs b/src/LanguageServer/LineColumns.hs index 9fccc7bf..b21bc71a 100644 --- a/src/LanguageServer/LineColumns.hs +++ b/src/LanguageServer/LineColumns.hs @@ -10,31 +10,31 @@ import Query (Query) import qualified Query import Rock import qualified Scope -import Span (LineColumn (LineColumns)) import qualified Span +import UTF16 -fromDefinitionName :: MonadFetch Query m => Scope.DefinitionKind -> Name.Qualified -> m (Maybe (Span.Relative -> Span.LineColumn)) +fromDefinitionName :: (MonadFetch Query m) => Scope.DefinitionKind -> Name.Qualified -> m (Maybe (Span.Relative -> UTF16.LineColumns)) fromDefinitionName definitionKind name@(Name.Qualified moduleName _) = do (_, maybeAbsolutePosition) <- fetch $ Query.DefinitionPosition definitionKind name toLineColumns <- fromAbsolute moduleName pure $ fmap ((toLineColumns .) . Span.absoluteFrom) maybeAbsolutePosition -fromAbsolute :: MonadFetch Query m => Name.Module -> m (Span.Absolute -> Span.LineColumn) +fromAbsolute :: (MonadFetch Query m) => Name.Module -> m (Span.Absolute -> UTF16.LineColumns) fromAbsolute moduleName = do maybeFilePath <- fetch $ Query.ModuleFile moduleName case maybeFilePath of Nothing -> - pure $ const $ Span.LineColumns (Position.LineColumn 0 0) (Position.LineColumn 0 0) + pure $ const $ UTF16.LineColumns (UTF16.LineColumn 0 0) (UTF16.LineColumn 0 0) Just filePath -> do rope <- fetch $ Query.FileRope filePath let toLineColumn (Position.Absolute i) = - case Rope.splitAt (fromIntegral i) rope of - Nothing -> Position.LineColumn 0 0 + case Rope.utf8SplitAt (fromIntegral i) rope of + Nothing -> UTF16.LineColumn 0 0 Just (rope', _) -> let Rope.Position row column = Rope.lengthAsPosition rope' - in Position.LineColumn (fromIntegral row) (fromIntegral column) + in UTF16.LineColumn (fromIntegral row) (fromIntegral column) toLineColumns (Span.Absolute start end) = - Span.LineColumns (toLineColumn start) (toLineColumn end) + UTF16.LineColumns (toLineColumn start) (toLineColumn end) return toLineColumns diff --git a/src/LanguageServer/References.hs b/src/LanguageServer/References.hs index a9dec052..b3be53d3 100644 --- a/src/LanguageServer/References.hs +++ b/src/LanguageServer/References.hs @@ -18,12 +18,13 @@ import Query (Query) import qualified Query import Rock import qualified Span +import qualified UTF16 references :: FilePath - -> Position.LineColumn - -> Task Query [(Intervals.Item, [(FilePath, Span.LineColumn)])] -references filePath (Position.LineColumn line column) = do + -> UTF16.LineColumn + -> Task Query [(Intervals.Item, [(FilePath, UTF16.LineColumns)])] +references filePath (UTF16.LineColumn line column) = do (originalModuleName, _, _) <- fetch $ Query.ParsedFile filePath let itemSpans definingModule item = do let mightUseDefiningModule moduleName header = @@ -46,14 +47,12 @@ references filePath (Position.LineColumn line column) = do pure $ (,) inputFile . toLineColumns . Span.absoluteFrom defPos <$> Intervals.itemSpans item occurrenceIntervals else pure mempty - contents <- fetch $ Query.FileText filePath - let - -- TODO use the rope that we get from the LSP library instead - pos = - Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) $ Rope.fromText contents of - Nothing -> 0 - Just (rope, _) -> fromIntegral $ Rope.length rope + contents <- fetch $ Query.FileRope filePath + let pos = + Position.Absolute $ + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of + Nothing -> 0 + Just (rope, _) -> fromIntegral $ Rope.utf8Length rope toLineColumns <- LineColumns.fromAbsolute originalModuleName spans <- fetch $ Query.ModuleSpanMap originalModuleName fmap concat $ diff --git a/src/Lexer.hs b/src/Lexer.hs index c10623de..9f205dbb 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -17,12 +17,11 @@ import Data.Coerce import Data.Text.Array (Array) import qualified Data.Text.Array as Array import qualified Data.Text.Internal as Text -import qualified Data.Text.Internal.Encoding.Utf16 as Utf16 -import qualified Data.Text.Internal.Unsafe.Char as Char +import qualified Data.Text.Internal.Encoding.Utf8 as Utf8 import qualified Position import Protolude hiding (State, ord, state) import qualified Span -import qualified UTF16 +import qualified UTF8 data TokenList = Empty @@ -108,6 +107,20 @@ data State = State , end :: !Position.Absolute } +{-# INLINE satisfy #-} +satisfy :: Word8 -> (Word8 -> Bool) -> (Char -> Bool) -> State -> Maybe Int +satisfy c satisfyASCII satisfyNonASCII State {..} + | c < 128 = if satisfyASCII c then Just 1 else Nothing + | otherwise = + case Utf8.utf8LengthByLeader c of + 2 | position + 1 < end, satisfyNonASCII (Utf8.chr2 c (index input $ position + 1)) -> Just 2 + 3 | position + 2 < end, satisfyNonASCII (Utf8.chr3 c (index input $ position + 1) (index input $ position + 2)) -> Just 3 + 4 | position + 3 < end, satisfyNonASCII (Utf8.chr4 c (index input $ position + 1) (index input $ position + 2) (index input $ position + 3)) -> Just 4 + _ -> Nothing + +incColumn :: Int -> State -> State +incColumn n state@State {..} = state {position = Position.add position (coerce n), lineColumn = Position.addColumns lineColumn (coerce n)} + lex :: State -> TokenList lex state@State {..} | position >= end = @@ -116,162 +129,118 @@ lex state@State {..} case index input position of ------------------------------------------------------------------------- -- Parens - [UTF16.unit1|(|] -> - token1 LeftParen $ lex state1 - [UTF16.unit1|)|] -> - token1 RightParen $ lex state1 + [UTF8.unit1|(|] -> + token1 LeftParen $ lex $ incColumn 1 state + [UTF8.unit1|)|] -> + token1 RightParen $ lex $ incColumn 1 state ------------------------------------------------------------------------- -- Comments - [UTF16.unit1|-|] - | position1 < end - , [UTF16.unit1|-|] <- index input position1 -> - singleLineComment state2 - [UTF16.unit1|{|] - | position1 < end - , [UTF16.unit1|-|] <- index input position1 -> - multiLineComment state2 1 + [UTF8.unit1|-|] + | position + 1 < end + , [UTF8.unit1|-|] <- index input (position + 1) -> + singleLineComment $ incColumn 2 state + [UTF8.unit1|{|] + | position + 1 < end + , [UTF8.unit1|-|] <- index input (position + 1) -> + multiLineComment (incColumn 2 state) 1 ------------------------------------------------------------------------- -- Whitespace - [UTF16.unit1| |] -> - lex state1 - [UTF16.unit1| |] -> - lex state1 - [UTF16.unit1| + [UTF8.unit1| |] -> + lex $ incColumn 1 state + [UTF8.unit1| |] -> + lex $ incColumn 1 state + [UTF8.unit1| |] -> - lex state1 {lineColumn = Position.addLine lineColumn} + lex (incColumn 1 state) {lineColumn = Position.addLine lineColumn} ------------------------------------------------------------------------- -- Number - [UTF16.unit1|\|] -> - token1 Lambda $ lex state1 + [UTF8.unit1|\|] -> + token1 Lambda $ lex $ incColumn 1 state ------------------------------------------------------------------------- -- Number - [UTF16.unit1|-|] - | position1 < end - , c <- index input position1 + [UTF8.unit1|-|] + | position + 1 < end + , c <- index input (position + 1) , isNumeric c -> - number position lineColumn state2 True (fromIntegral $ c - [UTF16.unit1|0|]) + number position lineColumn (incColumn 1 state) True (fromIntegral $ c - [UTF8.unit1|0|]) c | isNumeric c -> - number position lineColumn state1 False (fromIntegral $ c - [UTF16.unit1|0|]) + number position lineColumn (incColumn 1 state) False (fromIntegral $ c - [UTF8.unit1|0|]) ------------------------------------------------------------------------- -- Implicit braces - [UTF16.unit1|@|] - | position1 < end - , [UTF16.unit1|{|] <- index input position1 -> - token2 LeftImplicitBrace $ lex state2 - [UTF16.unit1|}|] -> - token1 RightImplicitBrace $ lex state1 + [UTF8.unit1|@|] + | position + 1 < end + , [UTF8.unit1|{|] <- index input (position + 1) -> + token2 LeftImplicitBrace $ lex $ incColumn 2 state + [UTF8.unit1|}|] -> + token1 RightImplicitBrace $ lex $ incColumn 1 state ------------------------------------------------------------------------- -- Operator or identifier c - | isASCIIIdentifierStart c -> - identifier position lineColumn state1 + | Just n <- satisfy c isASCIIIdentifierStart Char.isAlpha state -> + identifier position lineColumn $ incColumn n state c - | isASCIIOperator c -> - operator position lineColumn state1 - c - | c >= 128 - , Utf16.validate1 c - , c' <- Char.unsafeChr c - , Char.isAlpha c' -> - identifier position lineColumn state1 - c - | c >= 128 - , Utf16.validate1 c - , c' <- Char.unsafeChr c - , Char.isSymbol c' || Char.isPunctuation c' -> - operator position lineColumn state1 - c1 - | position1 < end - , c2 <- index input position1 - , Utf16.validate2 c1 c2 - , c <- Utf16.chr2 c1 c2 - , Char.isAlpha c -> - identifier position lineColumn state2 - c1 - | position1 < end - , c2 <- index input position1 - , Utf16.validate2 c1 c2 - , c <- Utf16.chr2 c1 c2 - , Char.isSymbol c || Char.isPunctuation c -> - operator position lineColumn state2 + | Just n <- satisfy c isASCIIOperator (\c' -> Char.isSymbol c' || Char.isPunctuation c') state -> + operator position lineColumn $ incColumn n state ------------------------------------------------------------------------- -- Error _ -> - token1 Error $ lex state1 + token1 Error $ lex $ incColumn 1 state where - state1 = - state - { position = position1 - , lineColumn = Position.addColumns lineColumn 1 - } - - state2 = - state - { position = position2 - , lineColumn = Position.addColumns lineColumn 2 - } - - position1 = - Position.add position 1 - - position2 = - Position.add position 2 - token1 = - Token lineColumn $ Span.Absolute position position1 + Token lineColumn $ Span.Absolute position (position + 1) token2 = - Token lineColumn $ Span.Absolute position position2 + Token lineColumn $ Span.Absolute position (position + 2) ------------------------------------------------------------------------------- -index :: Array -> Position.Absolute -> Word16 +index :: Array -> Position.Absolute -> Word8 index = coerce Array.unsafeIndex -isNumeric :: Word16 -> Bool +isNumeric :: Word8 -> Bool isNumeric c = - [UTF16.unit1|0|] <= c && c <= [UTF16.unit1|9|] + [UTF8.unit1|0|] <= c && c <= [UTF8.unit1|9|] -isASCIIIdentifierStart :: Word16 -> Bool +isASCIIIdentifierStart :: Word8 -> Bool isASCIIIdentifierStart c = - [UTF16.unit1|a|] <= c && c <= [UTF16.unit1|z|] - || [UTF16.unit1|A|] <= c && c <= [UTF16.unit1|Z|] - || c == [UTF16.unit1|_|] + [UTF8.unit1|a|] <= c && c <= [UTF8.unit1|z|] + || [UTF8.unit1|A|] <= c && c <= [UTF8.unit1|Z|] + || c == [UTF8.unit1|_|] -isASCIIIdentifierCont :: Word16 -> Bool +isASCIIIdentifierCont :: Word8 -> Bool isASCIIIdentifierCont c = isASCIIIdentifierStart c || isNumeric c - || c == [UTF16.unit1|'|] + || c == [UTF8.unit1|'|] -isASCIIOperator :: Word16 -> Bool +isASCIIOperator :: Word8 -> Bool isASCIIOperator c = case c of - [UTF16.unit1|!|] -> True - [UTF16.unit1|#|] -> True - [UTF16.unit1|$|] -> True - [UTF16.unit1|%|] -> True - [UTF16.unit1|&|] -> True - [UTF16.unit1|*|] -> True - [UTF16.unit1|+|] -> True - [UTF16.unit1|,|] -> True - [UTF16.unit1|-|] -> True - [UTF16.unit1|.|] -> True - [UTF16.unit1|/|] -> True - [UTF16.unit1|:|] -> True - [UTF16.unit1|;|] -> True - [UTF16.unit1|<|] -> True - [UTF16.unit1|=|] -> True - [UTF16.unit1|>|] -> True - [UTF16.unit1|?|] -> True - [UTF16.unit1|@|] -> True - [UTF16.unit1|\|] -> True - [UTF16.unit1|^|] -> True - [UTF16.unit1|`|] -> True - [UTF16.unit1|||] -> True - [UTF16.unit1|~|] -> True + [UTF8.unit1|!|] -> True + [UTF8.unit1|#|] -> True + [UTF8.unit1|$|] -> True + [UTF8.unit1|%|] -> True + [UTF8.unit1|&|] -> True + [UTF8.unit1|*|] -> True + [UTF8.unit1|+|] -> True + [UTF8.unit1|,|] -> True + [UTF8.unit1|-|] -> True + [UTF8.unit1|.|] -> True + [UTF8.unit1|/|] -> True + [UTF8.unit1|:|] -> True + [UTF8.unit1|;|] -> True + [UTF8.unit1|<|] -> True + [UTF8.unit1|=|] -> True + [UTF8.unit1|>|] -> True + [UTF8.unit1|?|] -> True + [UTF8.unit1|@|] -> True + [UTF8.unit1|\|] -> True + [UTF8.unit1|^|] -> True + [UTF8.unit1|`|] -> True + [UTF8.unit1|||] -> True + [UTF8.unit1|~|] -> True _ -> False ------------------------------------------------------------------------------- @@ -284,44 +253,13 @@ identifier identifier !startPosition !startLineColumn state@State {..} | position >= end = identifierToken input startPosition startLineColumn position Empty - | otherwise = - case index input position of - c - | isASCIIIdentifierCont c -> - identifier startPosition startLineColumn state1 - [UTF16.unit1|.|] -> - dotIdentifier startPosition startLineColumn position lineColumn state1 - c - | Utf16.validate1 c - , Char.isAlpha $ Char.unsafeChr c -> - identifier startPosition startLineColumn state1 - c1 - | position1 < end - , c2 <- index input position1 - , Utf16.validate2 c1 c2 - , Char.isAlpha $ Utf16.chr2 c1 c2 -> - identifier startPosition startLineColumn state2 - _ -> - identifierToken input startPosition startLineColumn position $ - lex state - where - state1 = - state - { position = position1 - , lineColumn = Position.addColumns lineColumn 1 - } - - state2 = - state - { position = position2 - , lineColumn = Position.addColumns lineColumn 2 - } - - position1 = - Position.add position 1 - - position2 = - Position.add position 2 + | otherwise = case index input position of + [UTF8.unit1|.|] -> + dotIdentifier startPosition startLineColumn position lineColumn $ incColumn 1 state + c | Just n <- satisfy c isASCIIIdentifierCont Char.isAlpha state -> identifier startPosition startLineColumn $ incColumn n state + _ -> + identifierToken input startPosition startLineColumn position $ + lex state dotIdentifier :: Position.Absolute @@ -332,64 +270,17 @@ dotIdentifier -> TokenList dotIdentifier !startPosition !startLineColumn !dotPosition !dotLineColumn state@State {..} | position >= end = - identifierToken input startPosition startLineColumn position $ + identifierToken input startPosition startLineColumn dotPosition $ Token dotLineColumn (Span.Absolute dotPosition position) Dot Empty - | otherwise = - case index input position of - c - | isASCIIIdentifierCont c -> - identifier startPosition startLineColumn state1 - c - | isASCIIOperator c -> - operator startPosition startLineColumn state1 - c - | c >= 128 - , Utf16.validate1 c - , c' <- Char.unsafeChr c - , Char.isAlpha c' -> - identifier startPosition startLineColumn state1 - c - | c >= 128 - , Utf16.validate1 c - , c' <- Char.unsafeChr c - , Char.isSymbol c' || Char.isPunctuation c' -> - operator startPosition startLineColumn state1 - c1 - | position1 < end - , c2 <- index input position1 - , Utf16.validate2 c1 c2 - , c <- Utf16.chr2 c1 c2 - , Char.isAlpha c -> - identifier startPosition startLineColumn state2 - c1 - | position1 < end - , c2 <- index input position1 - , Utf16.validate2 c1 c2 - , c <- Utf16.chr2 c1 c2 - , Char.isSymbol c || Char.isPunctuation c -> - operator startPosition startLineColumn state2 - _ -> - identifierToken input startPosition startLineColumn dotPosition $ - Token dotLineColumn (Span.Absolute dotPosition position) Dot $ - lex state - where - state1 = - state - { position = position1 - , lineColumn = Position.addColumns lineColumn 1 - } - - state2 = - state - { position = position2 - , lineColumn = Position.addColumns lineColumn 2 - } - - position1 = - Position.add position 1 - - position2 = - Position.add position 2 + | otherwise = case index input position of + c + | Just n <- satisfy c isASCIIIdentifierCont Char.isAlpha state -> identifier startPosition startLineColumn $ incColumn n state + | Just n <- satisfy c isASCIIOperator (\c' -> Char.isSymbol c' || Char.isPunctuation c') state -> + identifierToken input startPosition startLineColumn dotPosition $ operator dotPosition dotLineColumn $ incColumn n state + | otherwise -> + identifierToken input startPosition startLineColumn dotPosition $ + Token dotLineColumn (Span.Absolute dotPosition position) Dot $ + lex state identifierToken :: Array @@ -401,14 +292,14 @@ identifierToken identifierToken !input !startPosition !startLineColumn !position = Token startLineColumn (Span.Absolute startPosition position) $ case index input startPosition of - [UTF16.unit1|_|] | len == 1 -> Underscore - [UTF16.unit1|l|] | "let" <- str -> Let - [UTF16.unit1|i|] | "in" <- str -> In - [UTF16.unit1|d|] | "data" <- str -> Data - [UTF16.unit1|w|] | "where" <- str -> Where - [UTF16.unit1|f|] | "forall" <- str -> Forall - [UTF16.unit1|c|] | "case" <- str -> Case - [UTF16.unit1|o|] | "of" <- str -> Of + [UTF8.unit1|_|] | len == 1 -> Underscore + [UTF8.unit1|l|] | "let" <- str -> Let + [UTF8.unit1|i|] | "in" <- str -> In + [UTF8.unit1|d|] | "data" <- str -> Data + [UTF8.unit1|w|] | "where" <- str -> Where + [UTF8.unit1|f|] | "forall" <- str -> Forall + [UTF8.unit1|c|] | "case" <- str -> Case + [UTF8.unit1|o|] | "of" <- str -> Of _ -> Identifier str where len = @@ -428,47 +319,14 @@ operator -> State -> TokenList operator !startPosition !startLineColumn state@State {..} - | position >= end = - identifierToken input startPosition startLineColumn position Empty - | otherwise = - case index input position of - c - | isASCIIOperator c -> - operator startPosition lineColumn state1 - c - | c >= 128 - , Utf16.validate1 c - , c' <- Char.unsafeChr c - , Char.isSymbol c' || Char.isPunctuation c' -> - operator startPosition lineColumn state1 - c1 - | position1 < end - , c2 <- index input position1 - , Utf16.validate2 c1 c2 - , c <- Utf16.chr2 c1 c2 - , Char.isSymbol c || Char.isPunctuation c -> - operator startPosition lineColumn state2 - _ -> - operatorToken input startPosition startLineColumn position $ - lex state - where - state1 = - state - { position = position1 - , lineColumn = Position.addColumns lineColumn 1 - } - - state2 = - state - { position = position2 - , lineColumn = Position.addColumns lineColumn 2 - } - - position1 = - Position.add position 1 - - position2 = - Position.add position 2 + | position >= end = operatorToken input startPosition startLineColumn position Empty + | otherwise = case index input position of + c + | Just n <- satisfy c isASCIIOperator (\c' -> Char.isSymbol c' || Char.isPunctuation c') state -> + operator startPosition startLineColumn $ incColumn n state + | otherwise -> + operatorToken input startPosition startLineColumn position $ + lex state operatorToken :: Array @@ -480,13 +338,13 @@ operatorToken operatorToken !input !startPosition !startLineColumn !position = Token startLineColumn (Span.Absolute startPosition position) $ case index input startPosition of - [UTF16.unit1|=|] | len == 1 -> Equals - [UTF16.unit1|.|] | len == 1 -> Dot - [UTF16.unit1|:|] | len == 1 -> Colon - [UTF16.unit1|||] | len == 1 -> Pipe - [UTF16.unit1|-|] | "->" <- str -> RightArrow - [UTF16.unit1|?|] | len == 1 -> QuestionMark - [UTF16.unit1|~|] | len == 1 -> Forced + [UTF8.unit1|=|] | len == 1 -> Equals + [UTF8.unit1|.|] | len == 1 -> Dot + [UTF8.unit1|:|] | len == 1 -> Colon + [UTF8.unit1|||] | len == 1 -> Pipe + [UTF8.unit1|-|] | "->" <- str -> RightArrow + [UTF8.unit1|?|] | len == 1 -> QuestionMark + [UTF8.unit1|~|] | len == 1 -> Forced _ -> Operator str where len = @@ -515,8 +373,8 @@ number !startPosition !startLineColumn state@State {..} !shouldNegate !acc c | isNumeric c -> do let acc' = - acc * 10 + fromIntegral (c - [UTF16.unit1|0|]) - number startPosition startLineColumn state1 shouldNegate acc' + acc * 10 + fromIntegral (c - [UTF8.unit1|0|]) + number startPosition startLineColumn (incColumn 1 state) shouldNegate acc' _ -> token $ lex state where @@ -525,12 +383,6 @@ number !startPosition !startLineColumn state@State {..} !shouldNegate !acc Number $ if shouldNegate then negate acc else acc - state1 = - state - { position = Position.add position 1 - , lineColumn = Position.addColumns lineColumn 1 - } - ------------------------------------------------------------------------------- singleLineComment :: State -> TokenList @@ -539,14 +391,11 @@ singleLineComment state@State {..} Empty | otherwise = case index input position of - [UTF16.unit1| + [UTF8.unit1| |] -> - lex state {lineColumn = Position.addLine lineColumn} + lex (incColumn 1 state) {lineColumn = Position.addLine lineColumn} _ -> - singleLineComment state1 - where - state1 = - state {position = Position.add position 1} + singleLineComment $ incColumn 1 state multiLineComment :: State -> Int -> TokenList multiLineComment !state 0 = @@ -556,41 +405,23 @@ multiLineComment state@State {..} !depth Empty | otherwise = case index input position of - [UTF16.unit1|{|] - | position1 < end - , [UTF16.unit1|-|] <- index input position1 -> - multiLineComment state2 $ depth + 1 - [UTF16.unit1|-|] - | position1 < end - , [UTF16.unit1|}|] <- index input position1 -> - multiLineComment state2 (depth - 1) - [UTF16.unit1| + [UTF8.unit1|{|] + | position + 1 < end + , [UTF8.unit1|-|] <- index input (position + 1) -> + multiLineComment (incColumn 2 state) $ depth + 1 + [UTF8.unit1|-|] + | position + 1 < end + , [UTF8.unit1|}|] <- index input (position + 1) -> + multiLineComment (incColumn 2 state) (depth - 1) + [UTF8.unit1| |] -> multiLineComment - state1 + (incColumn 1 state) { lineColumn = Position.addLine lineColumn } depth _ -> - multiLineComment state1 depth - where - state1 = - state - { position = position1 - , lineColumn = Position.addColumns lineColumn 1 - } - - state2 = - state - { position = position2 - , lineColumn = Position.addColumns lineColumn 2 - } - - position1 = - Position.add position 1 - - position2 = - Position.add position 2 + multiLineComment (incColumn 1 state) depth -- TODO: Fuzz tests for -- length, line column diff --git a/src/Monad.hs b/src/Monad.hs index 7b4a72df..dca7d1a5 100644 --- a/src/Monad.hs +++ b/src/Monad.hs @@ -47,7 +47,7 @@ runM r = do { nextVar = nextVarVar } -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool allM _ [] = return True allM p (x : xs) = do b <- p x @@ -55,7 +55,7 @@ allM p (x : xs) = do then allM p xs else return False -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False anyM p (x : xs) = do b <- p x diff --git a/src/Occurrences.hs b/src/Occurrences.hs index 03c7b462..a1c47727 100644 --- a/src/Occurrences.hs +++ b/src/Occurrences.hs @@ -32,11 +32,11 @@ import Var (Var) newtype M a = M {run :: Monad.M a} deriving (Functor, Applicative, Monad, MonadFetch Query) -instance Semigroup a => Semigroup (M a) where +instance (Semigroup a) => Semigroup (M a) where M m <> M n = M $ (<>) <$> m <*> n -instance Monoid a => Monoid (M a) where +instance (Monoid a) => Monoid (M a) where mempty = pure mempty @@ -73,13 +73,13 @@ definitionOccurrences env definitionKind qualifiedName = foreach constructorSpans (\(span, con) -> Intervals.singleton span $ Intervals.Con con) <> foreach spans (`Intervals.singleton` Intervals.Global qualifiedName) -definitionNameSpans :: MonadFetch Query m => Scope.DefinitionKind -> Name.Qualified -> m [Span.Relative] +definitionNameSpans :: (MonadFetch Query m) => Scope.DefinitionKind -> Name.Qualified -> m [Span.Relative] definitionNameSpans definitionKind (Name.Qualified moduleName name) = do maybeParsedDefinition <- fetch $ Query.ParsedDefinition moduleName $ Mapped.Query (definitionKind, name) pure $ foldMap Surface.spans maybeParsedDefinition definitionConstructorSpans - :: MonadFetch Query m + :: (MonadFetch Query m) => Scope.DefinitionKind -> Name.Qualified -> m [(Span.Relative, Name.QualifiedConstructor)] diff --git a/src/Occurrences/Intervals.hs b/src/Occurrences/Intervals.hs index 34ed9f65..dff303b0 100644 --- a/src/Occurrences/Intervals.hs +++ b/src/Occurrences/Intervals.hs @@ -19,13 +19,13 @@ import qualified Data.HashSet as HashSet import Data.IntervalMap.FingerTree (IntervalMap) import qualified Data.IntervalMap.FingerTree as IntervalMap import qualified Data.List as List -import qualified Data.Text.Unsafe as Text import Literal (Literal) import qualified Name import Orphans () import qualified Position import Protolude import qualified Span +import qualified UTF16 import Var (Var) data Item @@ -136,19 +136,19 @@ varSpans var position intervals = do spanStart :: Span.Relative -> Position.Relative spanStart (Span.Relative s _) = s -nameSpan :: Item -> Span.LineColumn -> Span.LineColumn +nameSpan :: Item -> UTF16.LineColumns -> UTF16.LineColumns nameSpan item - span@(Span.LineColumns _ (Position.LineColumn endLine endColumn)) = + span@(UTF16.LineColumns _ (UTF16.LineColumn endLine endColumn)) = case item of Global (Name.Qualified _ (Name.Name name)) -> - Span.LineColumns - (Position.LineColumn endLine (endColumn - Text.lengthWord16 name)) - (Position.LineColumn endLine endColumn) + UTF16.LineColumns + (UTF16.LineColumn endLine (endColumn - UTF16.length name)) + (UTF16.LineColumn endLine endColumn) Con (Name.QualifiedConstructor _ (Name.Constructor name)) -> - Span.LineColumns - (Position.LineColumn endLine (endColumn - Text.lengthWord16 name)) - (Position.LineColumn endLine endColumn) + UTF16.LineColumns + (UTF16.LineColumn endLine (endColumn - UTF16.length name)) + (UTF16.LineColumn endLine endColumn) Lit _ -> span Var _ -> diff --git a/src/Orphans.hs b/src/Orphans.hs index 8048fab6..db7a67b4 100644 --- a/src/Orphans.hs +++ b/src/Orphans.hs @@ -23,7 +23,7 @@ instance (Enum k, Hashable k, Hashable v) => Hashable (EnumMap k v) where instance (Enum k, Hashable k) => Hashable (EnumSet k) where hashWithSalt s = hashWithSalt s . EnumSet.toList -instance Hashable k => Hashable (IntervalMap.Interval k) where +instance (Hashable k) => Hashable (IntervalMap.Interval k) where hashWithSalt s (IntervalMap.Interval a b) = hashWithSalt s (a, b) diff --git a/src/Parser.hs b/src/Parser.hs index 6499c87e..6fec1c08 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -507,7 +507,7 @@ pattern_ = <**> ( flip Surface.anno <$ token Lexer.Colon <*> term <|> pure identity ) - "pattern" + "pattern" plicitPattern :: Parser Surface.PlicitPattern plicitPattern = @@ -516,8 +516,8 @@ plicitPattern = <*> sepBy patName (token $ Lexer.Operator ",") <*> token Lexer.RightImplicitBrace <|> Surface.ExplicitPattern - <$> atomicPattern - "explicit or implicit pattern" + <$> atomicPattern + "explicit or implicit pattern" where mkImplicitPattern span1 pats span2 = Surface.ImplicitPattern (Span.add span1 span2) $ @@ -611,9 +611,9 @@ term = <* token Lexer.RightArrow <*> term <|> atomicTerm - <**> (foldl' (flip (.)) identity <$> many plicitAtomicTerm) - <**> fun - "term" + <**> (foldl' (flip (.)) identity <$> many plicitAtomicTerm) + <**> fun + "term" where typedBindings = uncurry (,,) @@ -642,7 +642,7 @@ definition = <$> ( Surface.TypeDeclaration span <$ token Lexer.Colon <*> recoveringTerm <|> Surface.ConstantDefinition <$> clauses span nameText ) - "definition" + "definition" clauses :: Span.Relative -> Text -> Parser [(Span.Relative, Surface.Clause)] clauses firstSpan nameText = diff --git a/src/Position.hs b/src/Position.hs index 69dcbf18..c28dd00c 100644 --- a/src/Position.hs +++ b/src/Position.hs @@ -6,8 +6,6 @@ module Position where -import qualified Data.Text as Text -import qualified Data.Text.Unsafe as Text import Protolude newtype Absolute = Absolute Int @@ -35,32 +33,3 @@ addLine (LineColumn line _) = addColumns :: LineColumn -> Int -> LineColumn addColumns (LineColumn line column) delta = LineColumn line $ column + delta - -lineColumn :: Absolute -> Text -> (LineColumn, Text) -lineColumn (Absolute index) text = - let prefix = - Text.takeWord16 index text - - suffix = - Text.dropWord16 index text - - linePrefixLength = - Text.lengthWord16 $ Text.takeWhileEnd (/= '\n') prefix - - lineSuffixLength = - Text.lengthWord16 $ Text.takeWhile (/= '\n') suffix - - lineStart = - index - linePrefixLength - - lineLength = - linePrefixLength + lineSuffixLength - - line = - Text.takeWord16 lineLength $ - Text.dropWord16 lineStart text - in ( LineColumn - (Text.count "\n" prefix) - linePrefixLength - , line - ) diff --git a/src/Query.hs b/src/Query.hs index 932ac257..1708ac0e 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -10,6 +10,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- Comes from deriveArgDict +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Query where @@ -87,7 +89,7 @@ data Query a where LLVMModuleInitModule :: Query Lazy.ByteString fetchImportedName - :: MonadFetch Query m + :: (MonadFetch Query m) => Name.Module -> Name.Surface -> m (Maybe Scope.Entry) @@ -148,7 +150,7 @@ instance Hashable (Query a) where LLVMModuleInitModule -> h 36 () where {-# INLINE h #-} - h :: Hashable b => Int -> b -> Int + h :: (Hashable b) => Int -> b -> Int h tag payload = hash tag `hashWithSalt` payload diff --git a/src/Query/Mapped.hs b/src/Query/Mapped.hs index 258e5eab..32fad6af 100644 --- a/src/Query/Mapped.hs +++ b/src/Query/Mapped.hs @@ -5,6 +5,7 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -49,7 +50,7 @@ rule inject query fetchMap = m <- fetch $ inject Map pure $ HashMap.lookup key m -instance Eq key => GEq (Query key result) where +instance (Eq key) => GEq (Query key result) where geq Map Map = Just Refl geq (Query k1) (Query k2) | k1 == k2 = Just Refl @@ -65,8 +66,7 @@ instance (Ord key) => GCompare (Query key result) where EQ -> GEQ GT -> GGT -instance ArgDict c (Query key result) where - type ConstraintsFor (Query key result) c = (c (HashMap key result), c (Maybe result)) +instance (c (Maybe result), c (HashMap key result)) => Has c (Query key result) where argDict query = case query of Map -> Dict diff --git a/src/Representation.hs b/src/Representation.hs index 6f652432..910205b3 100644 --- a/src/Representation.hs +++ b/src/Representation.hs @@ -61,7 +61,7 @@ instance Semigroup ContainsHeapPointers where instance Monoid ContainsHeapPointers where mempty = Doesn'tContainHeapPointers -maxM :: Monad m => [m Representation] -> m Representation +maxM :: (Monad m) => [m Representation] -> m Representation maxM [] = pure mempty maxM (m : ms) = do representation <- m diff --git a/src/Resolution.hs b/src/Resolution.hs index b79e561c..2dc0f3fc 100644 --- a/src/Resolution.hs +++ b/src/Resolution.hs @@ -123,7 +123,7 @@ exposedNames exposed m = Module.Exposed names -> HashMap.intersection m (HashSet.toMap names) -importedNames :: Semigroup a => Module.Import -> HashMap Name.Surface a -> HashMap Name.Surface a +importedNames :: (Semigroup a) => Module.Import -> HashMap Name.Surface a -> HashMap Name.Surface a importedNames import_ m = HashMap.unionWith (<>) unqualifiedNames qualifiedNames where diff --git a/src/Rules.hs b/src/Rules.hs index 63eadc3f..0db4a13e 100644 --- a/src/Rules.hs +++ b/src/Rules.hs @@ -245,7 +245,7 @@ rules sourceDirectories files readFile_ (Writer (Writer query)) = [] -> [] [(loc, (name, def))] -> - [((Surface.definitionKind def, name), Span.Absolute loc $ Position.Absolute $ Text.lengthWord16 text)] + [((Surface.definitionKind def, name), Span.Absolute loc $ Position.Absolute $ Text.lengthWord8 text)] (loc1, (name, def)) : defs'@((loc2, _) : _) -> ((Surface.definitionKind def, name), Span.Absolute loc1 loc2) : go defs' @@ -487,13 +487,13 @@ rules sourceDirectories files readFile_ (Writer (Writer query)) = pure $ AssemblyToLLVM.assembleModule [(Name.Lifted "$module_init" 0, assemblyDefinition)] where - input :: Functor m => m a -> m ((a, TaskKind), [Error]) + input :: (Functor m) => m a -> m ((a, TaskKind), [Error]) input = fmap ((,mempty) . (,Input)) - noError :: Functor m => m a -> m ((a, TaskKind), [Error]) + noError :: (Functor m) => m a -> m ((a, TaskKind), [Error]) noError = fmap ((,mempty) . (,NonInput)) - nonInput :: Functor m => m (a, [Error]) -> m ((a, TaskKind), [Error]) + nonInput :: (Functor m) => m (a, [Error]) -> m ((a, TaskKind), [Error]) nonInput = fmap (first (,NonInput)) runElaboratorWithDefault diff --git a/src/Span.hs b/src/Span.hs index 0993fd37..88206b7f 100644 --- a/src/Span.hs +++ b/src/Span.hs @@ -1,12 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Span where import qualified Position -import Prettyprinter import Protolude data Absolute = Absolute !Position.Absolute !Position.Absolute @@ -37,27 +35,3 @@ relativeContains (Relative start end) pos = data LineColumn = LineColumns !Position.LineColumn !Position.LineColumn deriving (Show, Generic) - -lineColumn :: Absolute -> Text -> (LineColumn, Text) -lineColumn (Absolute start end) text = - let (startLineColumn, lineText) = - Position.lineColumn start text - in ( LineColumns - startLineColumn - (fst $ Position.lineColumn end text) - , lineText - ) - --- | Gives a summary (fileName:row:column) of the location -instance Pretty LineColumn where - pretty - ( LineColumns - start@(Position.LineColumn ((+ 1) -> startLine) ((+ 1) -> startColumn)) - end@(Position.LineColumn ((+ 1) -> endLine) ((+ 1) -> endColumn)) - ) - | start == end = - pretty startLine <> ":" <> pretty startColumn - | startLine == endLine = - pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endColumn - | otherwise = - pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endLine <> ":" <> pretty endColumn diff --git a/src/Surface/Syntax.hs b/src/Surface/Syntax.hs index 932a8ba8..50694988 100644 --- a/src/Surface/Syntax.hs +++ b/src/Surface/Syntax.hs @@ -90,7 +90,7 @@ implicitApp :: Term -> HashMap Name Term -> Span.Relative -> Term implicitApp fun@(Term funSpan _) args endSpan = Term (Span.add funSpan endSpan) $ ImplicitApps fun args -lams :: Foldable f => Span.Relative -> f PlicitPattern -> Term -> Term +lams :: (Foldable f) => Span.Relative -> f PlicitPattern -> Term -> Term lams span vs body@(Term bodySpan _) = Term (Span.add span outerSpan) result where diff --git a/src/Telescope.hs b/src/Telescope.hs index e2744ca4..c62299b1 100644 --- a/src/Telescope.hs +++ b/src/Telescope.hs @@ -42,7 +42,7 @@ hoist f g tele = Extend name t plicity scope -> Extend name (f t) plicity $ hoist f g scope -hoistA :: Applicative f => (forall v'. t v' -> f (t' v')) -> (forall v'. k v' -> f (k' v')) -> Telescope n t k v -> f (Telescope n t' k' v) +hoistA :: (Applicative f) => (forall v'. t v' -> f (t' v')) -> (forall v'. k v' -> f (k' v')) -> Telescope n t k v -> f (Telescope n t' k' v) hoistA f g tele = case tele of Empty k -> @@ -70,7 +70,7 @@ foldr f g tele = f name t plicity $ Telescope.foldr f g scope foldMap - :: Monoid result + :: (Monoid result) => (forall v'. type_ v' -> result) -> (forall v'. base v' -> result) -> Telescope name type_ base v diff --git a/src/UTF16.hs b/src/UTF16.hs index a33fd461..29e516d3 100644 --- a/src/UTF16.hs +++ b/src/UTF16.hs @@ -1,31 +1,67 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module UTF16 where -import qualified Data.Char as Char -import qualified Data.Text.Internal.Encoding.Utf16 as Utf16 -import qualified Language.Haskell.TH.Lib as TH -import Language.Haskell.TH.Quote -import Protolude - -unit1 :: QuasiQuoter -unit1 = - QuasiQuoter - { quoteExp = \case - [c] - | word16 <- fromIntegral $ Char.ord c - , Utf16.validate1 word16 -> - TH.litE $ TH.integerL $ fromIntegral word16 - _ -> - panic "UTF16.unit1 needs a single char" - , quotePat = \case - [c] - | word16 <- fromIntegral $ Char.ord c - , Utf16.validate1 word16 -> - TH.litP $ TH.integerL $ fromIntegral word16 - _ -> - panic "UTF16.unit1 needs a single char" - , quoteType = panic "UTF16.unit1 quoteType" - , quoteDec = panic "UTF16.unit1 quoteDec" - } +import qualified Data.Text as Text +import qualified Data.Text.Unsafe as Text +import qualified Data.Text.Utf16.Lines as Utf16.Lines +import qualified Position +import Prettyprinter (Pretty (pretty)) +import Protolude hiding (length) +import qualified Span + +newtype CodeUnits = CodeUnits {toInt :: Int} + deriving (Eq, Ord, Show, Generic, NFData, Num) + +length :: Text -> CodeUnits +length = CodeUnits . fromIntegral . Utf16.Lines.length . Utf16.Lines.fromText + +data LineColumn = LineColumn !Int !CodeUnits + deriving (Eq, Ord, Show, Generic) + +data LineColumns = LineColumns !LineColumn !LineColumn + deriving (Show, Generic) + +lineColumn :: Position.Absolute -> Text -> (LineColumn, Text) +lineColumn (Position.Absolute index) text = + let prefix = Text.takeWord8 index text + suffix = Text.dropWord8 index text + linePrefix = Text.takeWhileEnd (/= '\n') prefix + linePrefixLength = Text.lengthWord8 linePrefix + linePrefixLength16 = length linePrefix + lineSuffixLength = Text.lengthWord8 $ Text.takeWhile (/= '\n') suffix + lineStart = index - linePrefixLength + lineLength = linePrefixLength + lineSuffixLength + line = Text.takeWord8 lineLength $ Text.dropWord8 lineStart text + in ( LineColumn + (Text.count "\n" prefix) + linePrefixLength16 + , line + ) + +lineColumns :: Span.Absolute -> Text -> (LineColumns, Text) +lineColumns (Span.Absolute start end) text = + let (startLineColumn, lineText) = + lineColumn start text + in ( LineColumns + startLineColumn + (fst $ lineColumn end text) + , lineText + ) + +-- | Gives a summary (fileName:row:column) of the location +instance Pretty LineColumns where + pretty + ( LineColumns + start@(LineColumn ((+ 1) -> startLine) (CodeUnits ((+ 1) -> startColumn))) + end@(LineColumn ((+ 1) -> endLine) (CodeUnits ((+ 1) -> endColumn))) + ) + | start == end = + pretty startLine <> ":" <> pretty startColumn + | startLine == endLine = + pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endColumn + | otherwise = + pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endLine <> ":" <> pretty endColumn diff --git a/src/UTF8.hs b/src/UTF8.hs new file mode 100644 index 00000000..b592ee4b --- /dev/null +++ b/src/UTF8.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module UTF8 where + +import qualified Data.Char as Char +import qualified Data.Text.Internal.Encoding.Utf8 as Utf8 +import qualified Language.Haskell.TH.Lib as TH +import Language.Haskell.TH.Quote +import Protolude + +unit1 :: QuasiQuoter +unit1 = + QuasiQuoter + { quoteExp = \case + [c] + | word8 <- fromIntegral $ Char.ord c + , Utf8.validate1 word8 -> + TH.litE $ TH.integerL $ fromIntegral word8 + _ -> + panic "UTF8.unit1 needs a single char" + , quotePat = \case + [c] + | word8 <- fromIntegral $ Char.ord c + , Utf8.validate1 word8 -> + TH.litP $ TH.integerL $ fromIntegral word8 + _ -> + panic "UTF8.unit1 needs a single char" + , quoteType = panic "UTF8.unit1 quoteType" + , quoteDec = panic "UTF8.unit1 quoteDec" + } diff --git a/stack.yaml b/stack.yaml index 80e7e453..27b6f7d3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,10 @@ -resolver: lts-20.26 +resolver: lts-22.7 packages: - . extra-deps: - dependent-hashmap-0.1.0.1 -- rock-0.3.1.1 +- rock-0.3.1.2 +- git: https://github.com/ollef/text-rope.git + commit: 22ccfdd795cfec5014acc3923b781a783afbdb06 - git: https://github.com/fpco/ghc-prof-flamegraph.git commit: 8edd3b4806adeb25a4d55bed51c3afcc8e7a8e14 -- enummapset-0.7.1.0 diff --git a/tests/singles/parsing/unicode.vix b/tests/singles/parsing/unicode.vix new file mode 100644 index 00000000..74734dab --- /dev/null +++ b/tests/singles/parsing/unicode.vix @@ -0,0 +1,11 @@ +β : Type +β = Type + +lol : β +lol = Type + +ࢄ : Type +ࢄ = Type + +𒀂 : Type +𒀂 = Type