Browse Source
Quality of Life improvments (#15)
Quality of Life improvments (#15)
Update Drone.yaml signature Remove ghc8.4.4 compatibility for now :( Even more Safe instances More pretty instances Add much needed pretty-printing instances Fix hie.yaml for VSCode Fix up lsp Clean up warnings Add -XTrustworthy and -XSafe all over the place Co-authored-by: Alex Feldman-Crough <alex@fldcr.com> Reviewed-on: #15master
James Alexander Feldman-Crough
1 year ago
20 changed files with 491 additions and 356 deletions
-
6.drone.yml
-
3.vscode/settings.json
-
9prosidy.cabal
-
2scripts/format
-
3src/Prosidy.hs
-
26src/Prosidy/Internal/Classes.hs
-
154src/Prosidy/Internal/JSON.hs
-
1src/Prosidy/Optics.hs
-
1src/Prosidy/Optics/Internal.hs
-
1src/Prosidy/Optics/Source.hs
-
1src/Prosidy/Optics/Types.hs
-
1src/Prosidy/Parse.hs
-
149src/Prosidy/Source.hs
-
130src/Prosidy/Source/LineMap.hs
-
46src/Prosidy/Source/Units.hs
-
171src/Prosidy/Types.hs
-
39src/Prosidy/Types/Assoc.hs
-
41src/Prosidy/Types/Key.hs
-
33src/Prosidy/Types/Series.hs
-
30src/Prosidy/Types/Set.hs
@ -0,0 +1,26 @@ |
|||
{- | |
|||
Module : Prosidy.Internal.Classes |
|||
Description : An internal module exporting common classes. |
|||
Copyright : (c) James Alexander Feldman-Crough, 2019 |
|||
License : MPL-2.0 |
|||
Maintainer : alex@fldcr.com |
|||
-} |
|||
{-# LANGUAGE Trustworthy #-} |
|||
module Prosidy.Internal.Classes (module X) where |
|||
|
|||
import Data.Aeson as X |
|||
( ToJSON(..) |
|||
, FromJSON(..) |
|||
, ToJSONKey(..) |
|||
, FromJSONKey(..) |
|||
) |
|||
import Data.Binary as X |
|||
( Binary(..) ) |
|||
import GHC.Generics as X |
|||
( Generic ) |
|||
import Control.DeepSeq as X |
|||
( NFData(..) ) |
|||
import Data.Hashable as X |
|||
( Hashable(..) ) |
|||
import Data.Text.Prettyprint.Doc as X |
|||
( Pretty(..) ) |
|||
@ -0,0 +1,154 @@ |
|||
{- | |
|||
Module : Prosidy.Internal.JSON |
|||
Description : Orphan JSON instances to let as many modules be -XSafe as possible. |
|||
Copyright : (c) James Alexander Feldman-Crough, 2019 |
|||
License : MPL-2.0 |
|||
Maintainer : alex@fldcr.com |
|||
-} |
|||
{-# OPTIONS_GHC -fno-warn-orphans #-} |
|||
{-# LANGUAGE OverloadedStrings #-} |
|||
{-# LANGUAGE Trustworthy #-} |
|||
module Prosidy.Internal.JSON () where |
|||
|
|||
import Prosidy.Internal.Classes |
|||
import Prosidy.Types |
|||
import Data.Aeson |
|||
import qualified Data.HashMap.Strict as HM |
|||
import Data.Text ( Text ) |
|||
import Control.Exception ( displayException ) |
|||
|
|||
instance FromJSON Block where |
|||
parseJSON = withObject "block" $ \o -> do |
|||
ty <- o .: "type" |
|||
case ty :: Text of |
|||
"tag" -> do |
|||
subtype <- o .: "subtype" |
|||
case subtype :: Text of |
|||
"block" -> BlockTag <$> o .: "value" |
|||
"literal" -> BlockLiteral <$> o .: "value" |
|||
_ -> fail $ "unknown tag subtype: " <> show subtype |
|||
"paragraph" -> BlockParagraph <$> o .: "value" |
|||
_ -> fail $ "unknown block type: " <> show ty |
|||
|
|||
instance ToJSON Block where |
|||
toEncoding b = pairs . mconcat $ case b of |
|||
BlockLiteral t -> |
|||
[ "type" .= ("tag" :: Text) |
|||
, "subtype" .= ("literal" :: Text) |
|||
, "value" .= t |
|||
] |
|||
BlockParagraph p -> ["type" .= ("paragraph" :: Text), "value" .= p] |
|||
BlockTag t -> |
|||
[ "type" .= ("tag" :: Text) |
|||
, "subtype" .= ("block" :: Text) |
|||
, "value" .= t |
|||
] |
|||
|
|||
toJSON b = object $ case b of |
|||
BlockLiteral t -> |
|||
[ "type" .= ("tag" :: Text) |
|||
, "subtype" .= ("literal" :: Text) |
|||
, "value" .= t |
|||
] |
|||
BlockParagraph p -> ["type" .= ("paragraph" :: Text), "value" .= p] |
|||
BlockTag t -> |
|||
[ "type" .= ("tag" :: Text) |
|||
, "subtype" .= ("block" :: Text) |
|||
, "value" .= t |
|||
] |
|||
|
|||
instance FromJSON Document where |
|||
parseJSON = withObject "Document" |
|||
$ \o -> Document <$> o .: "metadata" <*> o .: "content" |
|||
|
|||
instance ToJSON Document where |
|||
toEncoding (Document md ct) = |
|||
pairs $ mconcat ["metadata" .= md, "content" .= ct] |
|||
|
|||
toJSON (Document md ct) = object ["metadata" .= md, "content" .= ct] |
|||
|
|||
instance FromJSON Fragment where |
|||
parseJSON = withText "Fragment" $ pure . flip Fragment Nothing |
|||
|
|||
instance ToJSON Fragment where |
|||
toEncoding = toEncoding . fragmentText |
|||
toJSON = toJSON . fragmentText |
|||
|
|||
instance FromJSON Inline where |
|||
parseJSON = withObject "Inline" $ \o -> do |
|||
ty <- o .: "type" |
|||
case ty :: Text of |
|||
"break" -> pure Break |
|||
"tag" -> InlineTag <$> o .: "value" |
|||
"text" -> InlineText <$> o .: "value" |
|||
_ -> fail $ "unknown inline type: " <> show ty |
|||
|
|||
instance ToJSON Inline where |
|||
toEncoding i = pairs . mconcat $ case i of |
|||
Break -> ["type" .= ("break" :: Text), "value" .= Null] |
|||
InlineTag t -> |
|||
[ "type" .= ("tag" :: Text) |
|||
, "subtype" .= ("inline" :: Text) |
|||
, "value" .= t |
|||
] |
|||
InlineText t -> ["type" .= ("text" :: Text), "value" .= t] |
|||
|
|||
toJSON i = object $ case i of |
|||
Break -> ["type" .= ("break" :: Text)] |
|||
InlineTag t -> |
|||
[ "type" .= ("tag" :: Text) |
|||
, "subtype" .= ("inline" :: Text) |
|||
, "value" .= t |
|||
] |
|||
InlineText t -> ["type" .= ("text" :: Text), "value" .= t] |
|||
|
|||
instance FromJSON Metadata where |
|||
parseJSON = withObject "Metadata" |
|||
$ \o -> Metadata <$> o .: "properties" <*> o .: "settings" |
|||
|
|||
instance ToJSON Metadata where |
|||
toEncoding (Metadata ps ss) = |
|||
pairs $ mconcat ["properties" .= ps, "settings" .= ss] |
|||
|
|||
toJSON (Metadata ps ss) = object ["properties" .= ps, "settings" .= ss] |
|||
|
|||
instance FromJSON Paragraph where |
|||
parseJSON = fmap (flip Paragraph Nothing) . parseJSON |
|||
|
|||
instance ToJSON Paragraph where |
|||
toEncoding (Paragraph s _) = toEncoding s |
|||
toJSON (Paragraph s _) = toJSON s |
|||
|
|||
instance ToJSON a => ToJSON (Region a) where |
|||
toJSON (Region md ct _) = object ["metadata" .= md, "content" .= ct] |
|||
|
|||
instance FromJSON a => FromJSON (Tag a) where |
|||
parseJSON = withObject "Tag" $ \o -> |
|||
Tag |
|||
<$> o |
|||
.: "name" |
|||
<*> o |
|||
.: "metadata" |
|||
<*> o |
|||
.: "content" |
|||
<*> pure Nothing |
|||
|
|||
instance ToJSON a => ToJSON (Tag a) where |
|||
toEncoding (Tag nm md ct _) = |
|||
pairs $ mconcat ["name" .= nm, "metadata" .= md, "content" .= ct] |
|||
|
|||
toJSON (Tag nm md ct _) = |
|||
object ["name" .= nm, "metadata" .= md, "content" .= ct] |
|||
|
|||
instance FromJSONKey Key where |
|||
fromJSONKey = |
|||
FromJSONKeyTextParser $ either (fail . displayException) pure . makeKey |
|||
|
|||
instance (Hashable a, Eq a, ToJSONKey a) => ToJSON (Set a) where |
|||
toJSON (Set hs) = toJSON $ foldMap (flip HM.singleton True) hs |
|||
toEncoding (Set hs) = toEncoding $ foldMap (flip HM.singleton True) hs |
|||
|
|||
instance (Hashable a, Eq a, FromJSONKey a) => FromJSON (Set a) where |
|||
parseJSON json = do |
|||
m <- parseJSON json |
|||
pure . Set . HM.keysSet $ HM.filter id m |
|||
@ -0,0 +1,130 @@ |
|||
{- | |
|||
Module : Prosidy.Source.LineMap |
|||
Description : Binary-search tree for finding the position of new lines. |
|||
Copyright : (c) James Alexander Feldman-Crough, 2019 |
|||
License : MPL-2.0 |
|||
Maintainer : alex@fldcr.com |
|||
-} |
|||
{-# OPTIONS_GHC -fno-warn-orphans #-} |
|||
{-# LANGUAGE DerivingStrategies #-} |
|||
{-# LANGUAGE MultiParamTypeClasses #-} |
|||
{-# LANGUAGE DeriveGeneric #-} |
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
|||
{-# LANGUAGE TypeFamilies #-} |
|||
{-# LANGUAGE Trustworthy #-} |
|||
module Prosidy.Source.LineMap |
|||
( LineMap |
|||
, lineOffsets |
|||
, lineToOffset |
|||
, offsetToLine |
|||
, fromOffsets |
|||
) |
|||
where |
|||
|
|||
import qualified Data.Vector.Unboxed as V |
|||
import qualified Data.Vector.Generic as VG |
|||
import qualified Data.Vector.Generic.Mutable as VGM |
|||
import Data.Vector.Unboxed ( Vector |
|||
, MVector |
|||
, Unbox |
|||
) |
|||
|
|||
import Data.Foldable |
|||
import Data.List ( sort ) |
|||
|
|||
import Prosidy.Internal.Classes |
|||
import Prosidy.Source.Units |
|||
|
|||
-- | A dense vector containing offsets poiting to the start of each line. That |
|||
-- is, the starting position of the third line of a file can be found at |
|||
-- position 2. |
|||
newtype LineMap = LineMap (Vector Offset) |
|||
deriving stock (Eq, Generic) |
|||
deriving newtype (Show, NFData) |
|||
|
|||
instance Binary LineMap where |
|||
get = fmap (LineMap . V.fromList) get |
|||
put (LineMap v) = put (V.toList v) |
|||
|
|||
instance Hashable LineMap where |
|||
hashWithSalt salt (LineMap v) = V.foldl' hashWithSalt salt v |
|||
|
|||
fromOffsets :: Foldable f => f Offset -> LineMap |
|||
fromOffsets = LineMap . V.fromList . sort . toList |
|||
|
|||
-- | Convert a 'LineMap' into a list of 'Offset's, corresponding to the first |
|||
-- character of a line. Note that the initial offset is omitted-- the offset at |
|||
-- index 0 will be the offset of the /second/ line. |
|||
lineOffsets :: LineMap -> [Offset] |
|||
lineOffsets (LineMap v) = V.toList v |
|||
|
|||
-- | Fetch the 'Offset' for the given 'Line'. Evaluates to 'Nothing' if the |
|||
-- given 'Line' does not appear in the LineMap |
|||
lineToOffset :: Line -> LineMap -> Maybe Offset |
|||
lineToOffset (Line 0 ) _ = Just $ Offset 0 |
|||
lineToOffset (Line nth) (LineMap xs) = xs V.!? fromIntegral (pred nth) |
|||
|
|||
-- | Fetch the 'Line' number for a given 'Offset'. Newlines will be attributed |
|||
-- the line that they terminate, rather than the line started immediately |
|||
-- afterwards. |
|||
offsetToLine :: Offset -> LineMap -> Line |
|||
offsetToLine offset (LineMap xs) = Line . fromIntegral $ go Nothing |
|||
0 |
|||
(V.length xs) |
|||
where |
|||
go result min max |
|||
| min >= max |
|||
= maybe 0 succ result |
|||
| otherwise |
|||
= let nthIndex = ((max - min) `div` 2) + min |
|||
nthOffset = xs V.! nthIndex |
|||
in case nthOffset `compare` offset of |
|||
EQ -> succ nthIndex |
|||
LT -> go (Just nthIndex) (nthIndex + 1) max |
|||
GT -> go result min nthIndex |
|||
|
|||
newtype instance MVector s Offset = MV_Offset (MVector s Word) |
|||
|
|||
instance VGM.MVector MVector Offset where |
|||
basicLength (MV_Offset m) = VGM.basicLength m |
|||
{-# INLINE basicLength #-} |
|||
|
|||
basicUnsafeSlice ix len (MV_Offset m) = |
|||
MV_Offset $ VGM.basicUnsafeSlice ix len m |
|||
{-# INLINE basicUnsafeSlice #-} |
|||
|
|||
basicOverlaps (MV_Offset x) (MV_Offset y) = VGM.basicOverlaps x y |
|||
{-# INLINE basicOverlaps #-} |
|||
|
|||
basicUnsafeNew len = MV_Offset <$> VGM.basicUnsafeNew len |
|||
{-# INLINE basicUnsafeNew #-} |
|||
|
|||
basicInitialize (MV_Offset v) = VGM.basicInitialize v |
|||
{-# INLINE basicInitialize #-} |
|||
|
|||
basicUnsafeRead (MV_Offset v) = fmap Offset <$> VGM.basicUnsafeRead v |
|||
{-# INLINE basicUnsafeRead #-} |
|||
|
|||
basicUnsafeWrite (MV_Offset v) ix (Offset w) = VGM.basicUnsafeWrite v ix w |
|||
{-# INLINE basicUnsafeWrite #-} |
|||
|
|||
newtype instance Vector Offset = V_Offset (Vector Word) |
|||
|
|||
instance VG.Vector Vector Offset where |
|||
basicUnsafeFreeze (MV_Offset v) = V_Offset <$> VG.basicUnsafeFreeze v |
|||
{-# INLINE basicUnsafeFreeze #-} |
|||
|
|||
basicUnsafeThaw (V_Offset v) = MV_Offset <$> VG.basicUnsafeThaw v |
|||
{-# INLINE basicUnsafeThaw #-} |
|||
|
|||
basicLength (V_Offset v) = VG.basicLength v |
|||
{-# INLINE basicLength #-} |
|||
|
|||
basicUnsafeSlice ix len (V_Offset v) = |
|||
V_Offset $ VG.basicUnsafeSlice ix len v |
|||
{-# INLINE basicUnsafeSlice #-} |
|||
|
|||
basicUnsafeIndexM (V_Offset v) ix = Offset <$> VG.basicUnsafeIndexM v ix |
|||
{-# INLINE basicUnsafeIndexM #-} |
|||
|
|||
instance Unbox Offset where |
|||
@ -0,0 +1,46 @@ |
|||
{- | |
|||
Module : Prosidy.Source.Units |
|||
Description : Positional units for marking source-code locations. |
|||
Copyright : (c) James Alexander Feldman-Crough, 2019 |
|||
License : MPL-2.0 |
|||
Maintainer : alex@fldcr.com |
|||
-} |
|||
{-# LANGUAGE DeriveAnyClass #-} |
|||
{-# LANGUAGE DeriveGeneric #-} |
|||
{-# LANGUAGE DerivingVia #-} |
|||
{-# LANGUAGE DerivingStrategies #-} |
|||
{-# LANGUAGE OverloadedStrings #-} |
|||
{-# LANGUAGE Safe #-} |
|||
module Prosidy.Source.Units (Line(..), Column(..), Offset(..)) where |
|||
|
|||
import Prosidy.Internal.Classes |
|||
|
|||
-- | A line number. |
|||
-- |
|||
-- The 'Show' instance for 'Line' counts from one, while the internal |
|||
-- implementation counts from zero. |
|||
newtype Line = Line Word |
|||
deriving stock (Eq, Ord, Generic, Show) |
|||
deriving anyclass (Hashable, NFData, Binary) |
|||
deriving (ToJSON, FromJSON, Enum) via Word |
|||
|
|||
instance Pretty Line where |
|||
pretty (Line n) = pretty $ succ n |
|||
|
|||
-- | A column number. |
|||
newtype Column = Column Word |
|||
deriving stock (Eq, Ord, Generic, Show) |
|||
deriving anyclass (Hashable, NFData, Binary) |
|||
deriving (ToJSON, FromJSON, Enum) via Word |
|||
|
|||
instance Pretty Column where |
|||
pretty (Column n) = pretty $ succ n |
|||
|
|||
-- | An offset into a 'Source', counted by UTF-8 codepoint. |
|||
newtype Offset = Offset Word |
|||
deriving stock (Eq, Show, Ord, Generic) |
|||
deriving anyclass (Hashable, NFData, Binary) |
|||
deriving (ToJSON, FromJSON, Enum) via Word |
|||
|
|||
instance Pretty Offset where |
|||
pretty (Offset n) = "+" <> pretty n |
|||
Write
Preview
Loading…
Cancel
Save
Reference in new issue