prosidy 1.6.0.1 → 1.6.0.2

raw patch · 22 files changed

+617/−486 lines, 22 filesdep +base-compat-batteriesdep +prettyprinterdep −contravariantPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base-compat-batteries, prettyprinter

Dependencies removed: contravariant

API changes (from Hackage documentation)

Files

• prosidy.cabal +23/−19
• src/Prosidy.hs +3/−0
• src/Prosidy/Compat.hs +0/−8
• src/Prosidy/Internal/Classes.hs +26/−0
• src/Prosidy/Internal/JSON.hs +154/−0
• src/Prosidy/Optics.hs +1/−0
• src/Prosidy/Optics/Internal.hs +3/−1
• src/Prosidy/Optics/Source.hs +1/−0
• src/Prosidy/Optics/Types.hs +1/−0
• src/Prosidy/Parse.hs +3/−2
• src/Prosidy/Source.hs +16/−133
• src/Prosidy/Source/LineMap.hs +130/−0
• src/Prosidy/Source/Units.hs +46/−0
• src/Prosidy/Types.hs +39/−132
• src/Prosidy/Types/Assoc.hs +27/−12
• src/Prosidy/Types/Key.hs +8/−33
• src/Prosidy/Types/Series.hs +16/−13
• src/Prosidy/Types/Set.hs +9/−21
• test/Prosidy/Test.hs +6/−11
• test/Prosidy/Test/Parse.hs +34/−32
• test/Prosidy/Test/Source.hs +39/−37
• test/Prosidy/Test/Types.hs +32/−32

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

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

@@ -1,8 +0,0 @@-{-# LANGUAGE CPP #-}-module Prosidy.Compat -  ( MonadFail(..) -  ) where--#if __GLASGOW_HASKELL__ < 808-import Control.Monad.Fail (MonadFail(..))-#endif

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

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

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

@@ -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(..)

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

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

@@ -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 @\<stdin\>@.@@ -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

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

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

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

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

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

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

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

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

@@ -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 "<test>" ""-    assertBool "An empty source generates an empty line map." $-        null (PS.lineOffsets $ PS.sourceLineMap source)+    let source = PS.makeSource "<test>" ""+    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 "<test>" $ 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 "<test>" "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 "<test>" "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>" 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)

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