diff --git a/prosidy.cabal b/prosidy.cabal --- a/prosidy.cabal +++ b/prosidy.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: prosidy -version: 1.6.0.1 +version: 1.6.0.2 synopsis: A simple language for writing documents. license: MPL-2.0 license-file: LICENSE @@ -13,9 +13,9 @@ 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,24 +58,28 @@ other-modules: Prosidy.Optics.Internal - , Prosidy.Compat + , Prosidy.Source.LineMap + , Prosidy.Source.Units + , Prosidy.Internal.Classes + , Prosidy.Internal.JSON build-depends: - base >= 4.11 && < 5 - , aeson >= 1.4 && < 1.5 - , bytestring >= 0.10 && < 0.11 - , binary >= 0.8 && < 0.9 - , containers >= 0.6 && < 0.7 - , contravariant >= 1.5 && < 1.6 - , deepseq >= 1.4 && < 1.5 - , hashable >= 1.2 && < 1.4 - , megaparsec >= 7.0 && < 8.1 - , profunctors >= 5.3 && < 5.6 - , tagged >= 0.8 && < 0.9 - , text >= 1.2 && < 1.3 - , transformers >= 0.5 && < 0.6 - , vector >= 0.12 && < 0.13 - , unordered-containers >= 0.2 && < 0.3 + base >= 4.11 && < 5 + , base-compat-batteries >= 0.11 && < 0.12 + , aeson >= 1.4 && < 1.5 + , bytestring >= 0.10 && < 0.11 + , binary >= 0.8 && < 0.9 + , containers >= 0.6 && < 0.7 + , 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 + , transformers >= 0.5 && < 0.6 + , vector >= 0.12 && < 0.13 + , unordered-containers >= 0.2 && < 0.3 ------------------------------------------------------------------------------- test-suite prosidy-test diff --git a/src/Prosidy.hs b/src/Prosidy.hs --- a/src/Prosidy.hs +++ b/src/Prosidy.hs @@ -5,6 +5,7 @@ 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.Optics as X import Prosidy.Parse as X import Prosidy.Types as X + +import Prosidy.Internal.JSON ( ) diff --git a/src/Prosidy/Compat.hs b/src/Prosidy/Compat.hs deleted file mode 100644 --- a/src/Prosidy/Compat.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -module Prosidy.Compat - ( MonadFail(..) - ) where - -#if __GLASGOW_HASKELL__ < 808 -import Control.Monad.Fail (MonadFail(..)) -#endif diff --git a/src/Prosidy/Internal/Classes.hs b/src/Prosidy/Internal/Classes.hs new file mode 100644 --- /dev/null +++ b/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(..) ) diff --git a/src/Prosidy/Internal/JSON.hs b/src/Prosidy/Internal/JSON.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Prosidy/Optics.hs b/src/Prosidy/Optics.hs --- a/src/Prosidy/Optics.hs +++ b/src/Prosidy/Optics.hs @@ -5,6 +5,7 @@ License : MPL-2.0 Maintainer : alex@fldcr.com -} +{-# LANGUAGE Safe #-} module Prosidy.Optics (module X) where import Prosidy.Optics.Source as X diff --git a/src/Prosidy/Optics/Internal.hs b/src/Prosidy/Optics/Internal.hs --- a/src/Prosidy/Optics/Internal.hs +++ b/src/Prosidy/Optics/Internal.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE Safe #-} module Prosidy.Optics.Internal ( module Prosidy.Optics.Internal , Profunctor(..) @@ -26,7 +27,8 @@ ) import Data.Functor.Identity ( Identity(..) ) import Data.Tagged ( Tagged(..) ) -import Data.Functor.Contravariant ( Contravariant(..) ) +import Data.Functor.Contravariant.Compat + ( Contravariant(..) ) type Optic p f s t a b = p a (f b) -> p s (f t) type Iso s t a b = forall p f . (Profunctor p, Functor f) => Optic p f s t a b diff --git a/src/Prosidy/Optics/Source.hs b/src/Prosidy/Optics/Source.hs --- a/src/Prosidy/Optics/Source.hs +++ b/src/Prosidy/Optics/Source.hs @@ -5,6 +5,7 @@ License : MPL-2.0 Maintainer : alex@fldcr.com -} +{-# LANGUAGE Safe #-} module Prosidy.Optics.Source ( -- * Classy optics; implementable on all types with a location HasLocation(..) diff --git a/src/Prosidy/Optics/Types.hs b/src/Prosidy/Optics/Types.hs --- a/src/Prosidy/Optics/Types.hs +++ b/src/Prosidy/Optics/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Safe #-} module Prosidy.Optics.Types ( -- * Classy optics -- ** Items with 'Metadata' diff --git a/src/Prosidy/Parse.hs b/src/Prosidy/Parse.hs --- a/src/Prosidy/Parse.hs +++ b/src/Prosidy/Parse.hs @@ -5,12 +5,13 @@ License : MPL-2.0 Maintainer : alex@fldcr.com -} +{-# LANGUAGE Trustworthy #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE NoImplicitPrelude #-} module Prosidy.Parse ( -- * Parsing Prosidy types from 'Data.Text.Text' parseDocument @@ -24,7 +25,7 @@ ) where -import Prosidy.Compat +import Control.Monad.Fail.Compat ( MonadFail(..) ) import Prelude hiding ( fail ) import Prosidy.Types diff --git a/src/Prosidy/Source.hs b/src/Prosidy/Source.hs --- a/src/Prosidy/Source.hs +++ b/src/Prosidy/Source.hs @@ -5,15 +5,12 @@ 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,25 +34,16 @@ ) 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. -- -- The 'Show' instance for ths class does not include the 'LineMap' or 'Text' @@ -79,6 +67,9 @@ 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 @\@. @@ -86,7 +77,7 @@ 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 @@ 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 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 diff --git a/src/Prosidy/Source/LineMap.hs b/src/Prosidy/Source/LineMap.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Prosidy/Source/Units.hs b/src/Prosidy/Source/Units.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Prosidy/Types.hs b/src/Prosidy/Types.hs --- a/src/Prosidy/Types.hs +++ b/src/Prosidy/Types.hs @@ -5,15 +5,16 @@ 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 @@ ) where +import Prosidy.Internal.Classes + import Prosidy.Types.Assoc as X ( Assoc(..) ) import Prosidy.Types.Key as X @@ -67,21 +70,10 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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. diff --git a/src/Prosidy/Types/Assoc.hs b/src/Prosidy/Types/Assoc.hs --- a/src/Prosidy/Types/Assoc.hs +++ b/src/Prosidy/Types/Assoc.hs @@ -5,21 +5,25 @@ 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 @@ -- 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 @@ -- | 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 diff --git a/src/Prosidy/Types/Key.hs b/src/Prosidy/Types/Key.hs --- a/src/Prosidy/Types/Key.hs +++ b/src/Prosidy/Types/Key.hs @@ -5,24 +5,10 @@ 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 @@ ) 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 @@ , 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 @@ 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 diff --git a/src/Prosidy/Types/Series.hs b/src/Prosidy/Types/Series.hs --- a/src/Prosidy/Types/Series.hs +++ b/src/Prosidy/Types/Series.hs @@ -5,11 +5,11 @@ 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 @@ ) 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' ) @@ -50,8 +45,9 @@ -- 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 @@ -63,13 +59,17 @@ 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 = @@ -90,6 +90,9 @@ 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 diff --git a/src/Prosidy/Types/Set.hs b/src/Prosidy/Types/Set.hs --- a/src/Prosidy/Types/Set.hs +++ b/src/Prosidy/Types/Set.hs @@ -5,45 +5,33 @@ 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'. diff --git a/test/Prosidy/Test.hs b/test/Prosidy/Test.hs --- a/test/Prosidy/Test.hs +++ b/test/Prosidy/Test.hs @@ -1,21 +1,16 @@ -import Test.Tasty -import Test.Tasty.Runners.AntXML (antXMLRunner) +import Test.Tasty +import Test.Tasty.Runners.AntXML ( antXMLRunner ) import qualified Prosidy.Test.Source import qualified Prosidy.Test.Types import qualified Prosidy.Test.Parse main :: IO () main = tests >>= defaultMainWithIngredients ingredients - where - ingredients = defaultIngredients ++ - [ antXMLRunner - ] + where ingredients = defaultIngredients ++ [antXMLRunner] tests :: IO TestTree tests = do parseTests <- Prosidy.Test.Parse.tests - pure $ testGroup "test" - [ Prosidy.Test.Source.tests - , Prosidy.Test.Types.tests - , parseTests - ] + pure $ testGroup + "test" + [Prosidy.Test.Source.tests, Prosidy.Test.Types.tests, parseTests] diff --git a/test/Prosidy/Test/Parse.hs b/test/Prosidy/Test/Parse.hs --- a/test/Prosidy/Test/Parse.hs +++ b/test/Prosidy/Test/Parse.hs @@ -4,21 +4,23 @@ import qualified Prosidy -import Test.Tasty -import Test.Tasty.Golden.Advanced (goldenTest) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS.Lazy -import qualified System.Directory as Dir -import System.FilePath (()) -import Control.Exception (handle, displayException) +import Test.Tasty +import Test.Tasty.Golden.Advanced ( goldenTest ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified System.Directory as Dir +import System.FilePath ( () ) +import Control.Exception ( handle + , displayException + ) -import qualified Paths_prosidy as Paths -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Diff as Aeson.Diff -import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty +import qualified Paths_prosidy as Paths +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Diff as Aeson.Diff +import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty -import qualified Data.Text.Lazy as Text.Lazy -import Data.Text.Lazy.Encoding (decodeUtf8With) +import qualified Data.Text.Lazy as Text.Lazy +import Data.Text.Lazy.Encoding ( decodeUtf8With ) tests :: IO TestTree tests = do @@ -27,38 +29,38 @@ pure . testGroup "parse" $ makeTest goldenDir <$> goldenTests makeTest :: FilePath -> String -> TestTree -makeTest goldenDir name = - goldenTest name - (catchErrors getJSON) - (catchErrors parsePro) - compareDocs - writeGolden +makeTest goldenDir name = goldenTest name + (catchErrors getJSON) + (catchErrors parsePro) + compareDocs + writeGolden where getJSON :: IO Aeson.Value getJSON = do bytes <- BS.readFile $ goldenDir name "output.json" case Aeson.eitherDecode' . BS.Lazy.fromStrict $ bytes of - Left e -> fail $ "Failed to parse JSON: " <> e + Left e -> fail $ "Failed to parse JSON: " <> e Right ok -> pure ok parsePro :: IO Aeson.Value - parsePro = Aeson.toJSON <$> - Prosidy.readDocument (goldenDir name "input.pro") + parsePro = Aeson.toJSON + <$> Prosidy.readDocument (goldenDir name "input.pro") compareDocs :: Aeson.Value -> Aeson.Value -> IO (Maybe String) compareDocs gold test | gold == test = pure Nothing - compareDocs gold test = - let - diff = Aeson.Diff.diff (Aeson.toJSON gold) (Aeson.toJSON test) - pretty = Aeson.Pretty.encodePretty diff - in - pure . Just . Text.Lazy.unpack $ - "Golden test failed. The diff is included below:\n" <> - decodeUtf8With (\_ _ -> Just '\65533') pretty + compareDocs gold test = + let diff = Aeson.Diff.diff (Aeson.toJSON gold) (Aeson.toJSON test) + pretty = Aeson.Pretty.encodePretty diff + in pure + . Just + . Text.Lazy.unpack + $ "Golden test failed. The diff is included below:\n" + <> decodeUtf8With (\_ _ -> Just '\65533') pretty writeGolden :: Aeson.Value -> IO () - writeGolden doc = BS.Lazy.writeFile (goldenDir name "output.json") $ - Aeson.Pretty.encodePretty doc + writeGolden doc = + BS.Lazy.writeFile (goldenDir name "output.json") + $ Aeson.Pretty.encodePretty doc catchErrors :: IO a -> IO a catchErrors = handle $ \(e :: Prosidy.Failure) -> fail $ displayException e diff --git a/test/Prosidy/Test/Source.hs b/test/Prosidy/Test/Source.hs --- a/test/Prosidy/Test/Source.hs +++ b/test/Prosidy/Test/Source.hs @@ -1,19 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} module Prosidy.Test.Source (tests) where -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Data.Foldable (toList, for_) -import Data.IORef -import System.IO.Unsafe -import Control.Exception (evaluate) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Data.Foldable ( toList + , for_ + ) +import Data.IORef +import System.IO.Unsafe +import Control.Exception ( evaluate ) -import qualified Prosidy.Source as PS -import qualified Data.Text as T +import qualified Prosidy.Source as PS +import qualified Data.Text as T tests :: TestTree -tests = testGroup "source" +tests = testGroup + "source" [ testEmptyLineMap , testSimpleLineMap , testLineDelimiters @@ -24,9 +27,9 @@ testEmptyLineMap :: TestTree testEmptyLineMap = testCase "empty" $ do - let source = PS.makeSource "" "" - assertBool "An empty source generates an empty line map." $ - null (PS.lineOffsets $ PS.sourceLineMap source) + let source = PS.makeSource "" "" + assertBool "An empty source generates an empty line map." + $ null (PS.lineOffsets $ PS.sourceLineMap source) testSimpleLineMap :: TestTree testSimpleLineMap = testCase "simple" $ do @@ -34,14 +37,14 @@ [ "This source file contains a few lines." , "Some, line the next, are empty." , "" - , "Multiple consecutive empty lines are fine as well." + , "Multiple consecutive empty lines are fine as well." , "" , "" , "終わり" ] source = PS.makeSource "" $ T.unlines sourceLines - toList (PS.lineOffsets $ PS.sourceLineMap source) @?= - fmap PS.Offset [39, 71, 72, 123, 124, 125, 129] + toList (PS.lineOffsets $ PS.sourceLineMap source) + @?= fmap PS.Offset [39, 71, 72, 123, 124, 125, 129] for_ (zip [PS.Line 0 ..] sourceLines) $ \(lineNumber, line) -> PS.getSourceLine lineNumber source @?= Just (line <> "\n") @@ -50,13 +53,13 @@ let source = PS.makeSource "" "abc\ndef\rghi\r\njkl" lines = PS.sourceLineMap source PS.getSourceLine (PS.Line 0) source @?= Just "abc\n" - PS.lineToOffset (PS.Line 0) lines @?= Just (PS.Offset 0) + PS.lineToOffset (PS.Line 0) lines @?= Just (PS.Offset 0) PS.getSourceLine (PS.Line 1) source @?= Just "def\r" - PS.lineToOffset (PS.Line 1) lines @?= Just (PS.Offset 4) + PS.lineToOffset (PS.Line 1) lines @?= Just (PS.Offset 4) PS.getSourceLine (PS.Line 2) source @?= Just "ghi\r\n" - PS.lineToOffset (PS.Line 2) lines @?= Just (PS.Offset 8) + PS.lineToOffset (PS.Line 2) lines @?= Just (PS.Offset 8) PS.getSourceLine (PS.Line 3) source @?= Just "jkl" - PS.lineToOffset (PS.Line 3) lines @?= Just (PS.Offset 13) + PS.lineToOffset (PS.Line 3) lines @?= Just (PS.Offset 13) PS.getSourceLine (PS.Line 4) source @?= Nothing testLocation :: TestTree @@ -82,39 +85,38 @@ let source = PS.makeSource "" "abc\ndef" Just loc = PS.getLocation (PS.Offset 5) source (line, checkLine) <- checkEvaluated (PS.locationLine loc) - (col, checkCol) <- checkEvaluated (PS.locationColumn loc) + (col , checkCol ) <- checkEvaluated (PS.locationColumn loc) assertBool "line is unevaluated" . not =<< checkLine - assertBool "col is unevaluated" . not =<< checkCol + assertBool "col is unevaluated" . not =<< checkCol _ <- evaluate line - assertBool "line is evaluated" =<< checkLine - assertBool "col is unevaluated" . not =<< checkCol + assertBool "line is evaluated" =<< checkLine + assertBool "col is unevaluated" . not =<< checkCol _ <- evaluate col assertBool "line is evaluated" =<< checkLine - assertBool "col is evaluated" =<< checkCol + assertBool "col is evaluated" =<< checkCol propLineOffset :: TestTree -propLineOffset = testProperty "line-and-offset" $ - forAll gen $ \(source, initialOffset) -> +propLineOffset = + testProperty "line-and-offset" $ forAll gen $ \(source, initialOffset) -> let lineMap = PS.sourceLineMap source line = PS.offsetToLine initialOffset lineMap Just offset = PS.lineToOffset line lineMap line' = PS.offsetToLine offset lineMap - in (initialOffset >= offset) .&&. (line === line') + in (initialOffset >= offset) .&&. (line === line') where gen = do text <- T.pack <$> genChar - initialOffset <- elements [PS.Offset 0 .. toEnum (if T.null text then 0 else T.length text - 1)] + initialOffset <- + elements + [PS.Offset 0 .. toEnum + (if T.null text then 0 else T.length text - 1)] pure (PS.makeSource "" text, initialOffset) - genChar = listOf $ frequency - [ (10, elements ['a' .. 'z'] ) - , (4, pure ' ') - , (1, pure '\n') - ] + genChar = + listOf $ frequency + [(10, elements ['a' .. 'z']), (4, pure ' '), (1, pure '\n')] {-# NOINLINE checkEvaluated #-} checkEvaluated :: a -> IO (a, IO Bool) checkEvaluated val = do ref <- newIORef False - pure ( unsafePerformIO (writeIORef ref True) `seq` val - , readIORef ref - ) + pure (unsafePerformIO (writeIORef ref True) `seq` val, readIORef ref) diff --git a/test/Prosidy/Test/Types.hs b/test/Prosidy/Test/Types.hs --- a/test/Prosidy/Test/Types.hs +++ b/test/Prosidy/Test/Types.hs @@ -1,30 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} module Prosidy.Test.Types (tests) where -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck -import qualified Prosidy.Types.Key as Key -import qualified Prosidy.Types.Series as Series -import qualified Data.Text as Text -import qualified Data.Sequence as Seq +import qualified Prosidy.Types.Key as Key +import qualified Prosidy.Types.Series as Series +import qualified Data.Text as Text +import qualified Data.Sequence as Seq tests :: TestTree -tests = testGroup "types" - [ testKey - , testSeriesNE - ] +tests = testGroup "types" [testKey, testSeriesNE] testKey :: TestTree -testKey = testGroup "key" +testKey = testGroup + "key" [ testProperty "valid" $ forAll validGen $ \raw -> fmap Key.rawKey (Key.makeKey raw) === Right raw , testProperty "invalid-head" $ forAll invalidHeadGen $ \raw -> case Key.makeKey raw of Right _ -> label "key creation should fail" False - Left Key.EmptyKeyError -> label "key should be nonempty" $ property False - Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch)) -> - conjoin + Left Key.EmptyKeyError -> + label "key should be nonempty" $ property False + Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch)) + -> conjoin [ label "error string matches input" $ raw === raw' , label "invalid at index 0" $ nth === 0 , label "char is invalid" $ not (Key.isValidKeyHead ch) @@ -32,22 +31,23 @@ , testProperty "invalid-tail" $ forAll invalidTailGen $ \raw -> case Key.makeKey raw of Right _ -> label "key creation should fail" False - Left Key.EmptyKeyError -> label "key should be nonempty" $ property False - Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch)) -> - conjoin + Left Key.EmptyKeyError -> + label "key should be nonempty" $ property False + Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch)) + -> conjoin [ label "error string matches input" $ raw === raw' , label "invalid at index > 0" $ nth =/= 0 , label "char is invalid" $ not (Key.isValidKeyTail ch) ] - , testProperty "empty" $ - case Key.makeKey "" of - Right _ -> label "key creation should fail" False - Left Key.EmptyKeyError -> property () - Left (Key.InvalidCharacterError _) -> label "input should be empty" False + , testProperty "empty" $ case Key.makeKey "" of + Right _ -> label "key creation should fail" False + Left Key.EmptyKeyError -> property () + Left (Key.InvalidCharacterError _) -> + label "input should be empty" False ] where - arbHead = arbitraryUnicodeChar `suchThat` Key.isValidKeyHead - arbTail = listOf $ arbitraryUnicodeChar `suchThat` Key.isValidKeyTail + arbHead = arbitraryUnicodeChar `suchThat` Key.isValidKeyHead + arbTail = listOf $ arbitraryUnicodeChar `suchThat` Key.isValidKeyTail validGen = do keyHead <- arbHead @@ -67,12 +67,12 @@ pure . Text.pack $ keyHead : keyTail0 ++ keyTail1 : keyTail2 testSeriesNE :: TestTree -testSeriesNE = testGroup "SeriesNE" - [ testProperty "nonempty" $ - forAll genSeq1 $ \xs -> - fmap Series.toSeqNE (Series.fromSeqNE xs) === Just xs - , testProperty "empty" $ - Series.fromSeqNE (mempty :: Seq.Seq Word) === Nothing +testSeriesNE = testGroup + "SeriesNE" + [ testProperty "nonempty" $ forAll genSeq1 $ \xs -> + fmap Series.toSeqNE (Series.fromSeqNE xs) === Just xs + , testProperty "empty" + $ Series.fromSeqNE (mempty :: Seq.Seq Word) + === Nothing ] - where - genSeq1 = fmap Seq.fromList . listOf1 $ (arbitrary :: Gen Word) + where genSeq1 = fmap Seq.fromList . listOf1 $ (arbitrary :: Gen Word)