Browse Source

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: #15
master
James Alexander Feldman-Crough 2 years ago
parent
commit
41f1a08272
  1. 6
      .drone.yml
  2. 3
      .vscode/settings.json
  3. 9
      prosidy.cabal
  4. 2
      scripts/format
  5. 3
      src/Prosidy.hs
  6. 26
      src/Prosidy/Internal/Classes.hs
  7. 154
      src/Prosidy/Internal/JSON.hs
  8. 1
      src/Prosidy/Optics.hs
  9. 1
      src/Prosidy/Optics/Internal.hs
  10. 1
      src/Prosidy/Optics/Source.hs
  11. 1
      src/Prosidy/Optics/Types.hs
  12. 1
      src/Prosidy/Parse.hs
  13. 149
      src/Prosidy/Source.hs
  14. 130
      src/Prosidy/Source/LineMap.hs
  15. 46
      src/Prosidy/Source/Units.hs
  16. 171
      src/Prosidy/Types.hs
  17. 39
      src/Prosidy/Types/Assoc.hs
  18. 41
      src/Prosidy/Types/Key.hs
  19. 33
      src/Prosidy/Types/Series.hs
  20. 30
      src/Prosidy/Types/Set.hs

6
.drone.yml

@ -32,10 +32,6 @@ steps:
name: ghc 8.6.5
image: utdemir/ghc-musl:v4-integer-simple-ghc865
- <<: *default-steps
name: ghc 8.4.4
image: utdemir/ghc-musl:v4-libgmp-ghc844
- name: docs
image: utdemir/ghc-musl:v4-integer-simple-ghc881
depends_on:
@ -74,6 +70,6 @@ volumes:
path: /var/cache/cabal
---
kind: signature
hmac: 4182c9a06e0671846733a1cd1617ad52119e1a96be312770004503c6be80b553
hmac: 43d513b190eab1ed25a0877d256149f29fff80a26dafa0c3cd938c2dde711f2c
...

3
.vscode/settings.json

@ -13,5 +13,6 @@
"**/.env/**": true,
"**/dist/**": true,
"**/dist-newstyle/**": true
}
},
"hic.arguments": "--lsp --cwd src"
}

9
prosidy.cabal

@ -13,9 +13,9 @@ data-files: golden/**/*.pro, golden/**/*.json
extra-source-files: CHANGELOG.md, README.pro
tested-with:
GHC == 8.4.4
, GHC == 8.6.5
GHC == 8.6.5
, GHC == 8.8.1
, GHC == 8.8.3
description:
Prosidy is a small language for writing documents.
@ -58,6 +58,10 @@ library
other-modules:
Prosidy.Optics.Internal
, Prosidy.Source.LineMap
, Prosidy.Source.Units
, Prosidy.Internal.Classes
, Prosidy.Internal.JSON
build-depends:
base >= 4.11 && < 5
@ -69,6 +73,7 @@ library
, deepseq >= 1.4 && < 1.5
, hashable >= 1.2 && < 1.4
, megaparsec >= 7.0 && < 8.1
, prettyprinter >= 1.6 && < 1.7
, profunctors >= 5.3 && < 5.6
, tagged >= 0.8 && < 0.9
, text >= 1.2 && < 1.3

2
scripts/format

@ -43,7 +43,7 @@ grep \
--files-without-match \
--include '*.hs' \
--recursive \
'\{-#\s+ANN\s+module\s+"nofmt"\s+#-}' \
--regexp='{-# +LANGUAGE +ViewPatterns +#-}' \
src/ test/ \
| xargs -t brittany --config-file brittany.yaml --write-mode inplace
num_changed="$(git ls-files --exclude-standard --modified | tee /dev/tty | wc -l)"

3
src/Prosidy.hs

@ -5,6 +5,7 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE Safe #-}
module Prosidy (module X) where
import Prosidy.Source as X
@ -17,3 +18,5 @@ import Prosidy.Source as X
import Prosidy.Optics as X
import Prosidy.Parse as X
import Prosidy.Types as X
import Prosidy.Internal.JSON ( )

26
src/Prosidy/Internal/Classes.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(..) )

154
src/Prosidy/Internal/JSON.hs

@ -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

1
src/Prosidy/Optics.hs

@ -5,6 +5,7 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE Safe #-}
module Prosidy.Optics (module X) where
import Prosidy.Optics.Source as X

1
src/Prosidy/Optics/Internal.hs

@ -7,6 +7,7 @@ Maintainer : alex@fldcr.com
-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Safe #-}
module Prosidy.Optics.Internal
( module Prosidy.Optics.Internal
, Profunctor(..)

1
src/Prosidy/Optics/Source.hs

@ -5,6 +5,7 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE Safe #-}
module Prosidy.Optics.Source
( -- * Classy optics; implementable on all types with a location
HasLocation(..)

1
src/Prosidy/Optics/Types.hs

@ -8,6 +8,7 @@ Maintainer : alex@fldcr.com
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Safe #-}
module Prosidy.Optics.Types
( -- * Classy optics
-- ** Items with 'Metadata'

1
src/Prosidy/Parse.hs

@ -5,6 +5,7 @@ Copyright : (c) James Alexander Feldman-Crough, 2019
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ApplicativeDo #-}

149
src/Prosidy/Source.hs

@ -5,15 +5,12 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Safe #-}
module Prosidy.Source
( Source(..)
, Location
@ -37,24 +34,15 @@ module Prosidy.Source
)
where
import Data.Hashable ( Hashable(..) )
import Data.Vector.Unboxed ( Vector
, MVector
, Unbox
)
import Data.Text ( Text )
import GHC.Generics ( Generic )
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary(..) )
import Data.Aeson ( ToJSON(..)
, FromJSON(..)
)
import Control.Monad ( guard )
import qualified Data.Text as T
import qualified Data.Vector.Unboxed as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Text.Prettyprint.Doc as PP
import Prosidy.Internal.Classes
import Prosidy.Source.LineMap
import Prosidy.Source.Units
-- | Information about Prosidy source file.
--
@ -79,6 +67,9 @@ data Source = Source
instance Show Source where
show (Source fp _ _) = "Source " <> show fp
instance Pretty Source where
pretty = pretty . sourceName
-- | Create a 'Source' from a descriptive name and a body. The source name is
-- typically a 'FilePath', but this is not guarenteed. For instance, when read
-- from standard-input, Prosidy chooses to name the source @\<stdin\>@.
@ -86,7 +77,7 @@ makeSource :: String -> Text -> Source
makeSource name body = Source name body lineMap
where
lineMap = case T.foldl' lineMapFold (1, '\0', []) $ body of
(_, _, acc) -> LineMap . V.fromList . reverse $ acc
(_, _, acc) -> fromOffsets acc
lineMapFold (ix, prev, acc) ch
| ch == '\n' && prev == '\r' = (succ ix, ch, Offset ix : drop 1 acc)
| ch == '\n' || ch == '\r' = (succ ix, ch, Offset ix : acc)
@ -132,6 +123,10 @@ data Location = Location
deriving stock (Show, Generic, Eq)
deriving anyclass (NFData, Binary, Hashable)
instance Pretty Location where
pretty loc = pretty (locationSource loc) PP.<+> "@" PP.<+> mconcat
[pretty (locationLine loc), "×", pretty (locationColumn loc)]
-- | Add lazily computed line and column number information to a
-- 'SparseLocation'.
enrichLocation :: SparseLocation -> Location
@ -154,115 +149,3 @@ stripLocation :: Location -> SparseLocation
stripLocation l = SparseLocation { sparseLocationSource = locationSource l
, sparseLocationOffset = locationOffset l
}
-- | 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
-- | 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
-- | 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 newtype (ToJSON, FromJSON, Enum)
deriving anyclass (Hashable, NFData, Binary)
-- | A column number.
newtype Column = Column Word
deriving stock (Eq, Ord, Generic, Show)
deriving newtype (ToJSON, FromJSON, Enum)
deriving anyclass (Hashable, NFData, Binary)
-- | An offset into a 'Source', counted by UTF-8 codepoint.
newtype Offset = Offset Word
deriving stock (Eq, Show, Ord, Generic)
deriving newtype (ToJSON, FromJSON, Enum)
deriving anyclass (Hashable, NFData, Binary)
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

130
src/Prosidy/Source/LineMap.hs

@ -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

46
src/Prosidy/Source/Units.hs

@ -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

171
src/Prosidy/Types.hs

@ -5,15 +5,16 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
@ -49,6 +50,8 @@ module Prosidy.Types
)
where
import Prosidy.Internal.Classes
import Prosidy.Types.Assoc as X
( Assoc(..) )
import Prosidy.Types.Key as X
@ -67,21 +70,10 @@ import Prosidy.Types.Set as X
import Prosidy.Source ( Location )
import Data.Text ( Text )
import GHC.Generics ( Generic )
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary )
import Data.Hashable ( Hashable )
import Data.Aeson ( ToJSON(..)
, FromJSON(..)
, withObject
, withText
, (.:)
, (.=)
, object
, pairs
)
import qualified Data.Aeson as Aeson
import Data.Text.Prettyprint.Doc ( (<+>) )
import Data.Foldable ( toList )
import Prosidy.Types.Assoc ( toEntries )
import qualified Data.Text.Prettyprint.Doc as PP
-------------------------------------------------------------------------------
-- | A sum type enumerating allowed types inside of a block context.
@ -92,45 +84,10 @@ data Block =
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable, Binary, NFData)
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 Pretty Block where
pretty (BlockLiteral lit) = pretty lit
pretty (BlockParagraph pp ) = pretty pp
pretty (BlockTag tag) = pretty tag
-------------------------------------------------------------------------------
-- | A full Prosidy document.
@ -141,15 +98,8 @@ data Document = Document
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable, NFData, Binary)
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 Pretty Document where
pretty (Document md ct) = PP.nest 4 . PP.vsep $ [pretty md, pretty ct]
-- | Convert a 'Document' to a 'Region'. The resulting 'Region' will never have
-- a 'Location' attached.
@ -172,12 +122,8 @@ data Fragment = Fragment
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable, Binary, NFData)
instance FromJSON Fragment where
parseJSON = withText "Fragment" $ pure . flip Fragment Nothing
instance ToJSON Fragment where
toEncoding = toEncoding . fragmentText
toJSON = toJSON . fragmentText
instance Pretty Fragment where
pretty = pretty . fragmentText
-------------------------------------------------------------------------------
-- | A sum type enumerating allowed types inside of an inline context.
@ -196,33 +142,10 @@ data Inline =
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable, Binary, NFData)
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" .= Aeson.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 Pretty Inline where
pretty Break = "\9248"
pretty (InlineTag tag) = pretty tag
pretty (InlineText f ) = pretty f
-------------------------------------------------------------------------------
-- | A set of properties and settings, associated with a 'Region'.
@ -241,19 +164,21 @@ data Metadata = Metadata
instance Monoid Metadata where
mempty = Metadata mempty mempty
instance Pretty Metadata where
pretty (Metadata props sets)
| null props && null sets
= ""
| otherwise
= let props' = fmap pretty . toList $ props
sets' =
fmap (\(k, v) -> pretty k <+> PP.equals <+> pretty v)
. toEntries
$ sets
in PP.list $ props' ++ sets'
instance Semigroup Metadata where
Metadata p1 s1 <> Metadata p2 s2 = Metadata (p1 <> p2) (s1 <> s2)
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]
-------------------------------------------------------------------------------
-- | A non-empty collection of 'Inline' items. A 'Paragraph' represents the
-- border between block and inline contexts. All ancestors of a paragraph are
@ -265,12 +190,8 @@ data Paragraph = Paragraph
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable, NFData, Binary)
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 Pretty Paragraph where
pretty pg = "" PP.<+> pretty (paragraphContent pg)
-------------------------------------------------------------------------------
-- | An untagged structural grouping of items with type @a@. Regions do not
@ -283,8 +204,8 @@ data Region a = Region
deriving stock (Eq, Foldable, Functor, Show, Traversable, Generic)
deriving anyclass (Hashable, NFData, Binary)
instance ToJSON a => ToJSON (Region a) where
toJSON (Region md ct _) = Aeson.object ["metadata" .= md, "content" .= ct]
instance Pretty a => Pretty (Region a) where
pretty (Region md ct _) = PP.nest 4 $ PP.vsep ["§", pretty md, pretty ct]
-------------------------------------------------------------------------------
-- | A 'Region', annotated with a tag name.
@ -297,23 +218,9 @@ data Tag a = Tag
deriving stock (Eq, Foldable, Functor, Show, Traversable, Generic)
deriving anyclass (Hashable, NFData, Binary)
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 Pretty a => Pretty (Tag a) where
pretty (Tag name md ct _) =
PP.nest 4 $ PP.vsep [pretty name, pretty md, pretty ct]
-- | A 'Tag' containing zero or more 'Block' items.
-- Specified in Prosidy source with the @#-@ sigil.

39
src/Prosidy/Types/Assoc.hs

@ -5,21 +5,25 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Prosidy.Types.Assoc (Assoc(..), asHashMap, fromHashMap, toHashMap) where
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
module Prosidy.Types.Assoc
( Assoc(..)
, asHashMap
, fromHashMap
, toHashMap
, toEntries
)
where
import Prosidy.Internal.Classes
import Data.HashMap.Strict ( HashMap )
import GHC.Generics ( Generic )
import Data.Aeson ( ToJSON(..)
, FromJSON(..)
)
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary(..) )
import Data.Hashable ( Hashable(..) )
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Prettyprint.Doc as PP
-- | An associative mapping of keys to values.
--
@ -28,14 +32,21 @@ import qualified Data.HashMap.Strict as HM
-- 1) Add non-orphan instances to the underlying structure.
-- 2) Change the underlying type if needed.
newtype Assoc k v = Assoc (HashMap k v)
deriving stock (Generic)
deriving newtype (Eq, Foldable, Functor, Show, ToJSON, FromJSON, NFData, Semigroup, Monoid, Hashable)
deriving (Generic)
deriving (Eq, Show, ToJSON, FromJSON, NFData, Semigroup, Monoid, Hashable) via HashMap k v
deriving (Foldable, Functor) via HashMap k
instance (Eq k, Hashable k, Binary k, Binary v) => Binary (Assoc k v) where
get = Assoc . HM.fromList <$> get
put (Assoc hm) = put $ HM.toList hm
instance (Pretty k, Pretty v) => Pretty (Assoc k v) where
pretty (Assoc hm) =
PP.list
. map (\(k, v) -> pretty k PP.<+> PP.equals PP.<+> pretty v)
$ HM.toList hm
-- | Given a function which operates on a 'HashMap', return a function which
-- performs an equivalent transfromation on an 'Assoc'.
asHashMap
@ -52,3 +63,7 @@ fromHashMap = Assoc
-- | Convert an 'Assoc' to a 'HashMap'.
toHashMap :: Assoc k v -> HashMap k v
toHashMap (Assoc hm) = hm
-- | Convert an 'Assoc' into a list of key/value pairs.
toEntries :: Assoc k v -> [(k, v)]
toEntries (Assoc hm) = HM.toList hm

41
src/Prosidy/Types/Key.hs

@ -5,24 +5,10 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE Safe #-}
module Prosidy.Types.Key
( -- * The 'Key' type.
Key
@ -39,16 +25,9 @@ module Prosidy.Types.Key
)
where
import Prosidy.Internal.Classes
import Data.Text ( Text )
import Data.Aeson ( ToJSON(..)
, ToJSONKey(..)
, FromJSON(..)
, FromJSONKey(..)
)
import GHC.Generics ( Generic )
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary )
import Data.Hashable ( Hashable )
import Data.String ( IsString(..) )
import Data.Foldable ( for_ )
import Control.Monad ( unless )
@ -56,15 +35,14 @@ import Control.Exception ( Exception(..)
, throw
)
import qualified Data.Aeson as Aeson
import qualified Data.Char as Char
import qualified Data.Set as Set
import qualified Data.Text as Text
-- | A 'Key' is an identifier used in tags, properties, and setting names.
newtype Key = Key Text
deriving stock (Generic)
deriving newtype (Binary, Eq, Hashable, NFData, Ord, Show, ToJSON, ToJSONKey)
deriving stock (Show, Generic)
deriving (Binary, Eq, Hashable, NFData, Ord, ToJSON, ToJSONKey) via Text
-- | 'Key' exposes an 'IsString' instance, but beware! Invalid strings will
-- throw a pure exception.
@ -76,11 +54,8 @@ instance FromJSON Key where
text <- parseJSON json
either (fail . displayException) pure $ makeKey text
instance FromJSONKey Key where
fromJSONKey =
Aeson.FromJSONKeyTextParser
$ either (fail . displayException) pure
. makeKey
instance Pretty Key where
pretty = pretty . rawKey
-- | Create a new 'Key', checking its validity.
makeKey :: Text -> Either KeyError Key

33
src/Prosidy/Types/Series.hs

@ -5,11 +5,11 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE Safe #-}
module Prosidy.Types.Series
( -- * Possibly empty collections
Series(..)
@ -30,14 +30,9 @@ module Prosidy.Types.Series
)
where
import Prosidy.Internal.Classes
import Data.Sequence ( Seq )
import GHC.Generics ( Generic )
import Data.Aeson ( ToJSON(..)
, FromJSON(..)
)
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary(..) )
import Data.Hashable ( Hashable(..) )
import Data.Foldable ( toList
, foldl'
)
@ -45,15 +40,14 @@ import Control.Monad ( guard )
import qualified Data.Sequence as Seq
{-# ANN module "nofmt" #-}
-- | A newtype wrapper around a sequential collection.
--
-- Currently, 'Series' is implemented as a 'Seq', but this is not guarenteed to
-- be true.
newtype Series a = Series (Seq a)
deriving stock (Generic, Show)
deriving newtype (Eq, Foldable, Functor, Applicative, ToJSON, FromJSON, NFData, Semigroup, Monoid)
deriving (Generic, Show)
deriving (Eq, ToJSON, FromJSON, NFData, Semigroup, Monoid) via Seq a
deriving (Foldable, Functor, Applicative) via Seq
instance Binary a => Binary (Series a) where
get = Series . Seq.fromList <$> get
@ -65,13 +59,17 @@ instance Binary a => Binary (Series a) where
instance Hashable a => Hashable (Series a) where
hashWithSalt salt (Series xs) = foldl' hashWithSalt salt xs
instance Pretty a => Pretty (Series a) where
pretty = pretty . toList
instance Traversable Series where
traverse f (Series xs) = Series <$> traverse f xs
-- | A non-empty 'Series'.
newtype SeriesNE a = SeriesNE (Seq a)
deriving stock (Generic, Show)
deriving newtype (Eq, Foldable, Functor, Applicative, ToJSON, NFData, Semigroup)
deriving (Generic, Show)
deriving (Eq, ToJSON, NFData, Semigroup) via Seq a
deriving (Foldable, Functor, Applicative) via Seq
instance Binary a => Binary (SeriesNE a) where
get =
@ -93,6 +91,9 @@ instance FromJSON a => FromJSON (SeriesNE a) where
instance Hashable a => Hashable (SeriesNE a) where
hashWithSalt salt (SeriesNE xs) = foldl' hashWithSalt salt xs
instance Pretty a => Pretty (SeriesNE a) where
pretty = pretty . toList
instance Traversable SeriesNE where
traverse f (SeriesNE xs) = SeriesNE <$> traverse f xs
@ -161,4 +162,4 @@ fromSeqNE s | otherwise = Just (SeriesNE s)
-- | Convert a 'SeriesNE' into a 'Seq'. The returned 'Seq' is guarenteed to
-- always contain at least one element.
toSeqNE :: SeriesNE a -> Seq a
toSeqNE (SeriesNE a) = a
toSeqNE (SeriesNE a) = a

30
src/Prosidy/Types/Set.hs

@ -5,46 +5,34 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE Safe #-}
module Prosidy.Types.Set (Set(..), asHashSet, fromHashSet, toHashSet) where
import Prosidy.Internal.Classes
import Data.HashSet ( HashSet )
import GHC.Generics ( Generic )
import Data.Aeson ( FromJSONKey
, ToJSONKey
, ToJSON(..)
, FromJSON(..)
)
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary(..) )
import Data.Hashable ( Hashable(..) )
import qualified Data.HashSet as HS
import qualified Data.HashMap.Strict as HM
-- | A newtype wrapper around an unordered collection of unique elements.
--
-- Currently, this is implemented as a wrapper around a 'HashSet'.
newtype Set a = Set (HashSet a)
deriving stock (Generic)
deriving newtype (Eq, Foldable, Show, NFData, Semigroup, Monoid, Hashable)
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
deriving (Eq, Show, NFData, Semigroup, Monoid, Hashable) via HashSet a
deriving Foldable via HashSet
instance (Eq a, Hashable a, Binary a) => Binary (Set a) where
get = Set . HS.fromList <$> get
put (Set s) = put $ HS.toList s
instance Pretty a => Pretty (Set a) where
pretty = pretty . HS.toList . toHashSet
-- | Given a function which operates on 'HashSet's, return a function which
-- performs the same operation on a 'Set'.
asHashSet :: Functor f => (HashSet a -> f (HashSet b)) -> Set a -> f (Set b)

Loading…
Cancel
Save