packages feed

fractaltext (empty) → 0.1.0

raw patch · 31 files changed

+1193/−0 lines, 31 filesdep +basedep +containersdep +directory

Dependencies added: base, containers, directory, filepath, fractaltext, free, generic-data, hedgehog, json, microlens-platform, streaming, tasty, tasty-hedgehog, tasty-hunit, text, text-short, transformers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for fractaltext++## 0.1.0 -- 2025/02/25++* First version
+ LICENSE view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright 2025 0y2k++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ README.md view
@@ -0,0 +1,1 @@+# FractalText
+ fractaltext.cabal view
@@ -0,0 +1,81 @@+cabal-version:      3.8+name:               fractaltext+version:            0.1.0+synopsis:           Reference implementation of FractalText+description:+    Reference implementation of FractalText parser and serializer.+category:           Data+license:            Apache-2.0+license-file:       LICENSE+copyright:          (c) 2025 0y2k+author:             0y2k <0x0y2k@gmail.com>+maintainer:         0y2k <0x0y2k@gmail.com>+homepage:           https://github.com/0y2k/fractaltext-haskell+bug-reports:        https://github.com/0y2k/fractaltext-haskell/issues+build-type:         Simple+extra-doc-files:+    CHANGELOG.md,+    README.md,+    vendor/github.com/0y2k/fractaltext-test/README.md,+extra-source-files:+    vendor/github.com/0y2k/fractaltext-test/load/**/load_in.ft+    vendor/github.com/0y2k/fractaltext-test/load/**/load_out.json+    vendor/github.com/0y2k/fractaltext-test/load/**/load_err.json++source-repository head+    type:     git+    location: https://github.com/0y2k/fractaltext-haskell++common depends+    build-depends:+        base >=4.17 && <4.22,+        containers >=0.6.5 && <0.8,+        microlens-platform >=0.4.3.1 && <0.5,+        streaming >=0.2 && <0.3,+        text >=2.0 && <2.2,+        text-short >=0.1 && <0.2,+        vector >=0.13 && <0.14,++common warnings+    ghc-options: -Wall++library+    import:           depends, warnings+    default-language: Haskell2010+    hs-source-dirs:   src+    build-depends:+        free >=3.2 && <5.3,+        generic-data >=1.1 && <1.2,+        transformers >=0.6 && <0.7,+    exposed-modules:+        Data.FractalText,+        Data.FractalText.Annotate,+        Data.FractalText.From,+        Data.FractalText.Parse,+        Data.FractalText.Serialize,+        Data.FractalText.To,+        Data.FractalText.Type,+        Data.FractalText.Util,+    other-modules:+        Streaming.Parse,++test-suite fractaltext-test+    import:           depends, warnings+    default-language: Haskell2010+    hs-source-dirs:   test+    main-is:          Main.hs+    type:             exitcode-stdio-1.0+    build-tool-depends:+        tasty-discover:tasty-discover+    build-depends:+        fractaltext,+        directory,+        filepath,+        hedgehog,+        json,+        tasty,+        tasty-hedgehog,+        tasty-hunit,+    other-modules:+        Json,+        Property,
+ src/Data/FractalText.hs view
@@ -0,0 +1,10 @@+module Data.FractalText+  ( module X+  ) where++import Data.FractalText.From as X+import Data.FractalText.Parse as X+import Data.FractalText.Serialize as X+import Data.FractalText.To as X+import Data.FractalText.Type as X (Document, Item(..), ItemA(..), Key)+import Data.FractalText.Util as X (isValidDocument, removeAnnotation)
+ src/Data/FractalText/Annotate.hs view
@@ -0,0 +1,41 @@+module Data.FractalText.Annotate where++import Data.FractalText.Type+import Data.FractalText.Util++import Data.Functor.Identity (Identity(..))+import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V+import Lens.Micro.Platform++containsNewline :: T.Text -> Bool+containsNewline = isJust . T.findIndex (== '\n')++shouldQuote :: T.Text -> Bool+shouldQuote ts = T.null ts || case T.unpack ts of+  ' ':_ -> True+  ':':_ -> True+  '\"':ts1 -> case reverse ts1 of+    '\"':_ -> True+    _ -> False+  _ -> False++annotate :: Int -> Item -> ItemA+annotate isucc = go 0+ where+  h ts = ListElemA V.empty (shouldQuote ts) ts+  go _i Item'EmptyList = ItemA'EmptyList+  go i (Item'List vs) =+    let f (ListElem ts)+          | containsNewline ts = V.fromList $ map h+            $ runIdentity $ freeTToLines+            $ splitLines $ fromLazyText $ TL.fromStrict ts+          | otherwise = V.singleton $ h ts+     in ItemA'List i $ V.concatMap f vs+  go i (Item'Dict des) =+    let f de = DictElemA V.empty+          (de ^. dictElem'key)+          (go (i + isucc) $ de ^. dictElem'value)+     in ItemA'Dict i $ V.map f des
+ src/Data/FractalText/From.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.FractalText.From+  ( FromItem(..)+  , FromKey(..)+  , FromItemError'Common(..)+  , FromItemError'Map(..)+  ) where++import Data.FractalText.Type++import Control.Monad (forM)+import Data.Bifunctor (Bifunctor(first))+import Data.Kind (Type)+import qualified Data.Map as M+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import Data.Void (Void)+import Generic.Data+import Lens.Micro.Platform++class FromItem a where+  type FromItemError a :: Type+  fromItem :: Item -> Either (FromItemError a) a+class Ord a => FromKey a where+  type FromKeyError a :: Type+  fromKey :: Key -> Either (FromKeyError a) a++instance FromItem Item where+  type FromItemError Item = Void+  fromItem = Right++data FromItemError'Common+  = FromItemError'Common'InvalidValue+  deriving (Generic, Eq, Show)++instance FromItem TS.Text where+  type FromItemError TS.Text = FromItemError'Common+  fromItem (Item'List vs)+    | V.length vs == 1 = Right $ V.head vs ^. listElem'value+    | otherwise = Left FromItemError'Common'InvalidValue+  fromItem _ = Left FromItemError'Common'InvalidValue+instance FromItem TL.Text where+  type FromItemError TL.Text = FromItemError'Common+  fromItem (Item'List vs)+    | V.length vs == 1 = Right $ TL.fromStrict $ V.head vs ^. listElem'value+    | otherwise = Left FromItemError'Common'InvalidValue+  fromItem _ = Left FromItemError'Common'InvalidValue++instance a ~ TS.Text => FromItem [a] where+  type FromItemError [a] = FromItemError'Common+  fromItem (Item'List xs) = Right $ V.toList $ V.map (view listElem'value) xs+  fromItem _ = Left FromItemError'Common'InvalidValue+instance a ~ TS.Text => FromItem (V.Vector a) where+  type FromItemError (V.Vector a) = FromItemError'Common+  fromItem (Item'List xs) = Right $ V.map (view listElem'value) xs+  fromItem _ = Left FromItemError'Common'InvalidValue++instance FromKey TS.Text where+  type FromKeyError TS.Text = Void+  fromKey st = Right $ ST.toText st+instance FromKey TL.Text where+  type FromKeyError TL.Text = Void+  fromKey st = Right $ TL.fromStrict $ ST.toText st+instance FromKey ST.ShortText where+  type FromKeyError ST.ShortText = Void+  fromKey = Right++data FromItemError'Map k v+  = FromItemError'Map'InvalidValue+  | FromItemError'Map'KeyError (FromKeyError k)+  | FromItemError'Map'ValueError (FromItemError v)+  deriving (Generic)+instance (Eq (FromKeyError k), Eq (FromItemError v))+  => Eq (FromItemError'Map k v) where+    (==) = geq+instance (Show (FromKeyError k), Show (FromItemError v))+  => Show (FromItemError'Map k v) where+    showsPrec = gshowsPrec++instance (FromKey k, FromItem v) => FromItem (M.Map k v) where+  type FromItemError (M.Map k v) = FromItemError'Map k v+  fromItem (Item'Dict dic) =+    fmap M.fromList $ forM (V.toList dic) $ \de -> do+      kd <- first FromItemError'Map'KeyError $ fromKey $ de ^. dictElem'key+      vd <- first FromItemError'Map'ValueError $ fromItem $ de ^. dictElem'value+      return (kd, vd)+  fromItem _ = Left FromItemError'Map'InvalidValue
+ src/Data/FractalText/Parse.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++module Data.FractalText.Parse where++import Data.FractalText.Type+import Data.FractalText.Util++import Control.Monad (unless)+import Control.Monad.Trans.Class (MonadTrans(..))+import qualified Control.Monad.Trans.State.Strict as State+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import Generic.Data+import Prelude hiding (readList)+import qualified Streaming as S+import Streaming.Parse as SP+import qualified Streaming.Prelude as S++data ValidLine+  = ValidLine'Key (V.Vector SurplusLine) Int Key+  | ValidLine'String (V.Vector SurplusLine) Int T.Text+  deriving (Generic, Eq, Show)++data ParseError+  = ParseError'InvalidIndent+  | ParseError'UnexpectedEndOfInput+  | ParseError'UnexpectedLine+  deriving (Generic, Bounded, Enum, Eq, Ord, Show)++toLine :: T.Text -> Either ParseError Line+toLine ts =+  let ts0 = T.unpack ts+      countPrefixSpaces = go 0+       where+        go !n (' ':xs) = go (succ n) xs+        go !n _ = n+      indentLevel = countPrefixSpaces ts0+   in case drop indentLevel ts0 of+        [] -> Right Line'Blank+        '#':ts1 -> Right $ Line'Comment indentLevel $ T.pack ts1+        ':':ts1 -> Right $ Line'Key indentLevel $ ST.pack ts1+        '\t':_ts1 -> Left ParseError'InvalidIndent+        ts1 -> Right $ Line'String indentLevel $ T.pack ts1++loadLine :: TL.Text -> S.Stream (S.Of Line) (Either ParseError) ()+loadLine = S.mapM toLine . SP.folds (<>) T.empty id . splitLines . fromLazyText++toValidLine :: Monad m => S.Stream (S.Of Line) m ()+            -> S.Stream (S.Of ValidLine) m (V.Vector SurplusLine)+toValidLine s = go s []+ where+  go s0 ys = do+    ml <- lift $ S.next s0+    case ml of+      Left () -> return $ V.fromList $ reverse ys+      Right (Line'Blank, s1) -> go s1 $ SurplusLine'Blank : ys+      Right (Line'Comment i ts, s1) -> go s1 $ SurplusLine'Comment i ts : ys+      Right (Line'Key i k, s1) -> do+        S.yield $ ValidLine'Key (V.fromList $ reverse ys) i k+        go s1 []+      Right (Line'String i ts, s1) -> do+        S.yield $ ValidLine'String (V.fromList $ reverse ys) i ts+        go s1 []++validLine'Indent :: ValidLine -> Int+validLine'Indent (ValidLine'Key _sls i _k) = i+validLine'Indent (ValidLine'String _sls i _ts) = i++parse :: TL.Text -> Either ParseError Document+parse ts0 = runParser (readItem [EQ] 0) $ toValidLine $ loadLine ts0+ where+  runParser p s = do+    (ia, l) <- State.runStateT p s+    ex <- S.next l+    case ex of+      Left vs -> return (ia, vs)+      Right _ -> Left ParseError'UnexpectedLine+  readItem cs i = do+    ml <- SP.peek+    case ml of+      Nothing -> return ItemA'EmptyList+      Just (ValidLine'Key _sls j _k) -> do+        unless ((i `compare` j) `elem` cs)+          $ lift $ Left ParseError'InvalidIndent+        des <- readDict j+        return $ ItemA'Dict j des+      Just (ValidLine'String _sls j _ts) -> do+        unless ((i `compare` j) `elem` cs)+          $ lift $ Left ParseError'InvalidIndent+        es <- readList j+        return $ ItemA'List j es+  readDict i = postprocess <$> go []+   where+    go ys = do+      ml <- SP.draw+      case ml of+        Nothing -> return ys+        Just l@(ValidLine'Key sls j k) -> case i `compare` j of+          EQ -> do+            ml2 <- SP.peek+            case compare j . validLine'Indent <$> ml2 of+              Just LT -> do+                y <- readItem [LT] j+                go $ DictElemA sls k y : ys+              Just EQ -> go $ DictElemA sls k ItemA'EmptyList : ys+              _ -> return $ DictElemA sls k ItemA'EmptyList : ys+          GT -> do+            SP.unDraw l+            return ys+          LT -> lift $ Left ParseError'InvalidIndent+        Just l -> case i `compare` validLine'Indent l of+          GT -> do+            SP.unDraw l+            return ys+          _ -> lift $ Left ParseError'UnexpectedLine+    postprocess = V.fromList . reverse+  readList i = postprocess <$> go []+   where+    go ys = do+      ml <- SP.draw+      case ml of+        Nothing -> return ys+        Just l@(ValidLine'String sls j ts) -> case i `compare` j of+          EQ ->+            let (pss, q) = processString ts+             in go $ ListElemA sls q pss : ys+          GT -> do+            SP.unDraw l+            return ys+          LT -> lift $ Left ParseError'InvalidIndent+        Just l -> case i `compare` validLine'Indent l of+          GT -> do+            SP.unDraw l+            return ys+          _ -> lift $ Left ParseError'UnexpectedLine+    postprocess = V.fromList . reverse+  processString ts = case T.unpack ts of+    '\"':ts1 -> case reverse ts1 of+      '\"':ts2 -> (T.pack $ reverse ts2, True)+      _ -> (ts, False)+    _ -> (ts, False)++parseNaked :: TL.Text -> Either ParseError Item+parseNaked ts = removeAnnotation . fst <$> parse ts
+ src/Data/FractalText/Serialize.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.FractalText.Serialize where++import Data.FractalText.Annotate+import Data.FractalText.Type+import Data.FractalText.Util++import Control.Monad (forM_)+import Data.List (intersperse)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import Generic.Data+import qualified Streaming as S+import qualified Streaming.Prelude as S+import System.IO (Newline(..), nativeNewline)++osNewline :: T.Text+osNewline = T.pack $ case nativeNewline of+  LF -> "\n"+  CRLF -> "\r\n"++nl :: TLB.Builder+nl = TLB.fromText osNewline++indent :: Int -> TLB.Builder+indent i = TLB.fromString $ replicate i ' '++renderSurplusLines :: V.Vector SurplusLine -> TLB.Builder+renderSurplusLines sls = mconcat . intersperse nl+  . V.toList $ flip V.map sls $ \sl -> case sl of+    SurplusLine'Blank -> mempty+    SurplusLine'Comment i ts -> indent i <> TLB.fromText ts++renderSurplusLinesA :: V.Vector SurplusLine -> TLB.Builder+renderSurplusLinesA v = if V.null v then mempty else renderSurplusLines v <> nl+renderSurplusLinesB :: V.Vector SurplusLine -> TLB.Builder+renderSurplusLinesB v = if V.null v then mempty else nl <> renderSurplusLines v++data SerializeError+  = SerializeError'InvalidDocument+  deriving (Generic, Bounded, Enum, Eq, Ord, Show)++serialize :: Document -> Either SerializeError TL.Text+serialize doc@(ia, sls0)+  | isValidDocument doc =+    let x = go ia+     in Right $ TLB.toLazyText $ x <> renderSurplusLinesA sls0 <> nl+  | otherwise = Left SerializeError'InvalidDocument+ where+  go ItemA'EmptyList = mempty+  go (ItemA'List i es) =+    let f (ListElemA sls q ts) =+          let x0 = TLB.fromText ts+              x1 = if q then quotationMark <> x0 <> quotationMark else x0+           in renderSurplusLinesB sls <> indent i <> x1+     in mconcat $ intersperse nl $ map f $ V.toList es+  go (ItemA'Dict i des) =+    let f (DictElemA sls k v) =+          renderSurplusLinesB sls <> indent i <> renderKey k <> case v of+            ItemA'EmptyList -> mempty+            _ -> nl <> go v+     in mconcat $ intersperse nl $ map f $ V.toList des++  renderKey k = TLB.fromString ":" <> TLB.fromText (ST.toText k)+  quotationMark = TLB.fromString "\""++serializeNaked :: Int -> Item -> Either SerializeError TL.Text+serializeNaked isucc = serialize . (\it -> (it, V.empty)) . annotate isucc++dumpLine :: Monad m => Document+         -> Either SerializeError (S.Stream (S.Of Line) m ())+dumpLine doc@(ia, sls0)+  | isValidDocument doc = Right $ go ia >> dumpSurplusLines sls0+  | otherwise = Left SerializeError'InvalidDocument+ where+  go ItemA'EmptyList = return ()+  go (ItemA'List i es) = forM_ es $ dumpListElem i+  go (ItemA'Dict i des) = forM_ des $ dumpDictElem i+  dumpSurplusLines = S.each . V.map f+   where+    f SurplusLine'Blank = Line'Blank+    f (SurplusLine'Comment i ts) = Line'Comment i ts+  dumpListElem i (ListElemA sls q ts) = do+    dumpSurplusLines sls+    S.yield $ Line'String i+      $ if q then T.singleton '\"' <> ts <> T.singleton '\"' else ts+  dumpDictElem i (DictElemA sls k v) = do+    dumpSurplusLines sls+    S.yield $ Line'Key i k+    go v
+ src/Data/FractalText/To.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.FractalText.To+  ( ToItem(..)+  , ToKey(..)+  , ToItemError'Map(..)+  ) where++import Data.FractalText.Type++import Control.Monad (forM)+import Data.Bifunctor (Bifunctor(first))+import Data.Kind (Type)+import qualified Data.Map as M+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import Data.Void (Void)+import Generic.Data++class ToItem a where+  type ToItemError a :: Type+  toItem :: a -> Either (ToItemError a) Item+class ToKey a where+  type ToKeyError a :: Type+  toKey :: a -> Either (ToKeyError a) Key++instance ToItem Item where+  type ToItemError Item = Void+  toItem = Right++instance ToItem TS.Text where+  type ToItemError TS.Text = Void+  toItem = Right . Item'List . V.singleton . ListElem+instance ToItem TL.Text where+  type ToItemError TL.Text = Void+  toItem = Right . Item'List . V.singleton . ListElem . TL.toStrict++instance a ~ TS.Text => ToItem [a] where+  type ToItemError [a] = Void+  toItem = Right . Item'List . V.fromList . map ListElem+instance a ~ TS.Text => ToItem (V.Vector a) where+  type ToItemError (V.Vector a) = Void+  toItem = Right . Item'List . V.map ListElem++instance ToKey TS.Text where+  type ToKeyError TS.Text = Void+  toKey = Right . ST.fromText+instance ToKey TL.Text where+  type ToKeyError TL.Text = Void+  toKey = Right . ST.fromText . TL.toStrict+instance ToKey ST.ShortText where+  type ToKeyError ST.ShortText = Void+  toKey = Right++data ToItemError'Map k v+  = ToItemError'Map'KeyError (ToKeyError k)+  | ToItemError'Map'ValueError (ToItemError v)+  deriving (Generic)+instance (Eq (ToKeyError k), Eq (ToItemError v))+  => Eq (ToItemError'Map k v) where+    (==) = geq+instance (Show (ToKeyError k), Show (ToItemError v))+  => Show (ToItemError'Map k v) where+    showsPrec = gshowsPrec++instance (ToKey k, ToItem v) => ToItem (M.Map k v) where+  type ToItemError (M.Map k v) = ToItemError'Map k v+  toItem dic = fmap (Item'Dict . V.fromList)+    $ forM (M.toAscList dic) $ \(ks, vs) -> do+      kd <- first ToItemError'Map'KeyError $ toKey ks+      vd <- first ToItemError'Map'ValueError $ toItem vs+      return $ DictElem kd vd
+ src/Data/FractalText/Type.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.FractalText.Type where++import qualified Data.Text as T+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import Generic.Data+import Lens.Micro.Platform++type Key = ST.ShortText++newtype ListElem a = ListElem+  { _listElem'value :: a+  }+  deriving (Generic, Eq, Functor, Show)++data DictElem a = DictElem+  { _dictElem'key :: Key+  , _dictElem'value :: a+  }+  deriving (Generic, Eq, Functor, Show)++data Item+  = Item'EmptyList+  | Item'List (V.Vector (ListElem T.Text))+  | Item'Dict (V.Vector (DictElem Item))+  deriving (Generic, Eq, Show)++data Line+  = Line'Blank+  | Line'Comment Int T.Text+  | Line'Key Int Key+  | Line'String Int T.Text+  deriving (Generic, Eq, Show)++data SurplusLine+  = SurplusLine'Blank+  | SurplusLine'Comment Int T.Text+  deriving (Generic, Eq, Show)++type Quoted = Bool++data ListElemA a = ListElemA+  { _listElemA'surplusLines :: V.Vector SurplusLine+  , _listElemA'quoted :: Bool+  , _listElemA'value :: a+  }+  deriving (Generic, Eq, Functor, Show)++data DictElemA a = DictElemA+  { _dictElemA'surplusLines :: V.Vector SurplusLine+  , _dictElemA'key :: Key+  , _dictElemA'value :: a+  }+  deriving (Generic, Eq, Functor, Show)++data ItemA+  = ItemA'EmptyList+  | ItemA'List Int (V.Vector (ListElemA T.Text))+  | ItemA'Dict Int (V.Vector (DictElemA ItemA))+  deriving (Generic, Eq, Show)++type Document = (ItemA, V.Vector SurplusLine)++$(makeLenses ''ListElem)+$(makeLenses ''DictElem)+$(makeLenses ''ListElemA)+$(makeLenses ''DictElemA)
+ src/Data/FractalText/Util.hs view
@@ -0,0 +1,102 @@+module Data.FractalText.Util where++import Data.FractalText.Type++import Control.Monad.Trans.Free+import Data.Functor (($>))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V+import Lens.Micro.Platform+import Prelude hiding (break, span)+import qualified Streaming as S+import qualified Streaming.Prelude as S++nextChar :: Monad m+         => S.Stream (S.Of T.Text) m r+         -> m (Either r (Char, S.Stream (S.Of T.Text) m r))+nextChar s0 = do+  mx <- S.next s0+  case mx of+    Left r -> return $ Left r+    Right (x, s1) -> case T.uncons x of+      Nothing -> nextChar s1+      Just (c, y) -> return $ Right (c, S.yield y >> s1)++span :: Monad m => (Char -> Bool) -> S.Stream (S.Of T.Text) m r+     -> S.Stream (S.Of T.Text) m (S.Stream (S.Of T.Text) m r)+span predicate = go+ where+  go s0 = do+    ex <- S.lift $ S.next s0+    case ex of+      Left r -> return $ return r+      Right (x, s1) -> do+        let (prefix, suffix) = T.span predicate x+        if T.null suffix+          then do+            S.yield x+            go s1+          else do+            S.yield prefix+            return $ S.yield suffix >> s1++break :: Monad m => (Char -> Bool) -> S.Stream (S.Of T.Text) m r+      -> S.Stream (S.Of T.Text) m (S.Stream (S.Of T.Text) m r)+break predicate = span (not . predicate)++splitLines :: Monad m+           => S.Stream (S.Of T.Text) m r+           -> FreeT (S.Stream (S.Of T.Text) m) m r+splitLines p0 = FreeT $ go1 p0+ where+  go0 r = return $ Free $ S.yield T.empty $> FreeT (return $ Pure r)+  go1 p1 = do+    ec <- S.next p1+    case ec of+      Left r -> go0 r+      Right (txt, p2) -> if T.null txt+        then go1 p2+        else return $ Free $ go2 $ S.yield txt >> p2+  go2 p1 = do+    p2 <- break (\c -> c == '\n' || c == '\r') p1+    return $ FreeT $ do+      ec1 <- nextChar p2+      case ec1 of+        Left r -> return $ Pure r+        Right ('\n', p3) -> go1 p3+        Right ('\r', p3) -> do+          ec2 <- nextChar p3+          case ec2 of+            Left r -> go0 r+            Right ('\n', p4) -> go1 p4+            Right (c, p4) -> go1 $ S.yield (T.singleton c) >> p4+        Right _ -> error "splitLines: unreachable"++freeTToLines :: Monad m => FreeT (S.Stream (S.Of T.Text) m) m r -> m [T.Text]+freeTToLines ft = do+  step <- runFreeT ft+  case step of+    Pure _ -> return []+    Free p0 -> do+      line S.:> p1 <- S.fold (<>) T.empty id p0+      rest <- freeTToLines p1+      return $ line : rest++fromLazyText :: Monad m => TL.Text -> S.Stream (S.Of T.Text) m ()+fromLazyText = TL.foldrChunks (\e a -> S.yield e >> a) (return ())++removeAnnotation :: ItemA -> Item+removeAnnotation ItemA'EmptyList = Item'EmptyList+removeAnnotation (ItemA'List _l es) = Item'List $ flip V.map es $ \e ->+  ListElem $ e ^. listElemA'value+removeAnnotation (ItemA'Dict _l des) = Item'Dict $ flip V.map des $ \de ->+  DictElem (de ^. dictElemA'key) (removeAnnotation $ de ^. dictElemA'value)++isValidDocument :: Document -> Bool+isValidDocument = go . fst+ where+  go ItemA'EmptyList = True+  go (ItemA'List _l es) = not $ V.null es+  go (ItemA'Dict _l des) = not (V.null des)+    && V.all (go . view dictElemA'value) des
+ src/Streaming/Parse.hs view
@@ -0,0 +1,53 @@+module Streaming.Parse where++import Control.Monad.Trans.Free+import qualified Control.Monad.Trans.State.Strict as State+import qualified Streaming as S+import qualified Streaming.Prelude as S++type Parser a b m r = State.StateT (S.Stream (S.Of a) m b) m r++draw :: Monad m => Parser a b m (Maybe a)+draw = do+  s0 <- State.get+  ex <- S.lift $ S.next s0+  case ex of+    Left r -> do+      State.put $ return r+      return Nothing+    Right (a, s1) -> do+      State.put s1+      return $ Just a++unDraw :: Monad m => a -> Parser a b m ()+unDraw a = State.modify $ S.cons a++peek :: Monad m => Parser a b m (Maybe a)+peek = do+  ma <- draw+  mapM_ unDraw ma+  return ma++isEndOfInput :: Monad m => Parser a b m Bool+isEndOfInput = do+  ma <- peek+  return $ case ma of { Nothing -> True; Just _ -> False }++folds :: Monad m => (x -> a -> x) -> x -> (x -> b)+      -> FreeT (S.Stream (S.Of a) m) m r+      -> S.Stream (S.Of b) m r+folds step begin done = go+ where+  go f0 = do+    x <- S.lift $ runFreeT f0+    case x of+      Pure r -> return r+      Free s -> do+        (f1, b) <- S.lift $ fold s begin+        S.yield b+        go f1+  fold s0 x = do+    ea <- S.next s0+    case ea of+      Left f -> return (f, done x)+      Right (a, s1) -> fold s1 $! step x a
+ test/Json.hs view
@@ -0,0 +1,103 @@+module Json where++import Data.FractalText+import Data.FractalText.Annotate+import Data.FractalText.Type++import Control.Monad (forM)+import Data.Maybe (catMaybes)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TLIO+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import System.Directory (doesFileExist, listDirectory)+import System.FilePath ((</>))+import System.IO (IOMode(..), hSetEncoding, hSetNewlineMode, nativeNewlineMode,+                  noNewlineTranslation, openFile, utf8)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import qualified Text.JSON as J++data TestLoad+  = TestLoad'Nothing+  | TestLoad'Success FilePath FilePath+  | TestLoad'Failure FilePath+  deriving (Eq, Show)++newtype I = I { unI :: Item }+newtype IA = IA { unIA :: ItemA }++instance J.JSON I where+  readJSON (J.JSArray arr) =+    I . Item'List . V.fromList . map ListElem <$> forM arr J.readJSON+  readJSON (J.JSObject jsobj) =+    fmap (I . Item'Dict . V.fromList)+    $ forM (J.fromJSObject jsobj) $ \(k, v) -> do+      it <- J.readJSON v+      return $ DictElem (ST.pack k) (unI it)+  readJSON _ = J.Error "cannot convert json to fractaltext item"+  showJSON _ = error "unimplemented"+instance J.JSON IA where+  readJSON jsv = IA . annotate 4 . unI <$> J.readJSON jsv+  showJSON _ = error "unimplemented"++loadPlaintext :: FilePath -> IO TL.Text+loadPlaintext file = do+  h <- openFile file ReadMode+  hSetEncoding h utf8+  hSetNewlineMode h noNewlineTranslation+  TLIO.hGetContents h++loadJSON :: FilePath -> IO (Maybe Item)+loadJSON file = do+  h <- openFile file ReadMode+  hSetEncoding h utf8+  hSetNewlineMode h nativeNewlineMode+  ts <- TLIO.hGetContents h+  return $ case J.decode $ TL.unpack ts of+    J.Ok (I i) -> Just i+    J.Error _err -> Nothing++test_json :: IO [TestTree]+test_json = do+  let dir = "vendor"+        </> "github.com"+        </> "0y2k"+        </> "fractaltext-test"+        </> "load"+      skipLoad = []+  ds <- listDirectory dir+  ts <- forM ds $ \d0 -> do+    let d = dir </> d0+        fileLoadIn = d </> "load_in.ft"+        fileLoadOut = d </> "load_out.json"+        fileLoadErr = d </> "load_err.json"+    fli <- doesFileExist fileLoadIn+    tl <- if not fli then return TestLoad'Nothing else do+      flo <- doesFileExist fileLoadOut+      fle <- doesFileExist fileLoadErr+      return $ case (flo, fle) of+        (True, False) -> TestLoad'Success fileLoadIn fileLoadOut+        (False, True) -> TestLoad'Failure fileLoadIn+        (True, True) -> error $ d0 ++ ": ambiguous expected result"+        (False, False) -> error $ d0 ++ ": no expected result"+    return (d0, tl)+  tgl <- fmap (testGroup "load" . catMaybes) $ forM ts $ \(d, tl) ->+    if d `elem` skipLoad then return Nothing else case tl of+      TestLoad'Nothing -> return Nothing+      TestLoad'Success fin fout -> do+        mjout <- loadJSON fout+        case mjout of+          Just iout -> do+            pin <- loadPlaintext fin+            return $ Just $ testCase d $ case parseNaked pin of+              Right iin -> iin @?= iout+              Left err -> assertFailure $ show err+          Nothing -> return Nothing+      TestLoad'Failure fin -> do+        pin <- loadPlaintext fin+        return $ Just $ testCase d $ case parseNaked pin of+          Left _err -> return ()+          Right iin -> assertFailure+            $ "load succeed! it should fail: " ++ show iin+  return [tgl]
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Property.hs view
@@ -0,0 +1,59 @@+module Property where++import Data.FractalText+import Data.FractalText.Annotate+import Data.FractalText.Type++import qualified Data.Char as C+import Data.Either (isRight)+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Short as ST+import qualified Data.Vector as V+import qualified Hedgehog as H+import qualified Hedgehog.Gen as HG+import qualified Hedgehog.Range as HR+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++genItem' :: H.MonadGen m => H.Range Int -> H.Range Int -> H.Range Int -> m Item+genItem' rs rk rn = go+ where+  go = HG.recursive HG.choice+    [ return Item'EmptyList+    ]+    [ fmap (Item'List . V.fromList) $ HG.list rn+      $ ListElem . T.pack <$> HG.string rs char+    , Item'Dict . V.fromList <$> entries+    ]+  entries = do+    ks <- HG.set rn $ ST.pack <$> HG.string rk char+    vs <- HG.list rn go+    return $ zipWith DictElem (S.toAscList ks) vs+  char = HG.filterT C.isPrint HG.unicode++genItem :: H.MonadGen m => m Item+genItem = genItem' (HR.linear 0 64) (HR.linear 0 16) (HR.linear 1 32)++test_property :: TestTree+test_property = testGroup "property"+  [ testProperty "removeAnnotation . annotate === id" $ H.property $ do+    n <- H.forAll $ HG.integral $ HR.linear 1 8+    item <- H.forAll genItem+    removeAnnotation (annotate n item) H.=== item+  , testProperty "serialize . annotate === Right" $ H.property $ do+    n <- H.forAll $ HG.integral $ HR.linear 1 8+    item <- H.forAll genItem+    H.assert $ isRight $ serialize (annotate n item, V.empty)+  , testProperty "parseNaked <=< serializeNaked === Right" $ H.property $ do+    n <- H.forAll $ HG.integral $ HR.linear 1 8+    item <- H.forAll genItem+    let ets = serializeNaked n item+    case ets of+      Left err -> H.annotateShow err >> H.failure+      Right ts -> do+        let eit = parseNaked ts+        case eit of+          Left err -> H.annotateShow err >> H.failure+          Right it -> it H.=== item+  ]
+ vendor/github.com/0y2k/fractaltext-test/README.md view
@@ -0,0 +1,9 @@+# Test for FractalText++FractalText specification is available in+[github.com/0y2k/fractaltext-spec](https://github.com/0y2k/fractaltext-spec).++For each cases under `load` directory:+- The test try to load `load_in.ft` file.+- If `load_out.json` exists, the test should succeed.+- If `load_err.json` exists, the test should fail.
+ vendor/github.com/0y2k/fractaltext-test/load/comment_1/load_in.ft view
@@ -0,0 +1,8 @@+# This is a comment line+#+#continues+:key 1+  # comment of "value 1"+  value 1+    # indented comment+  value 2
+ vendor/github.com/0y2k/fractaltext-test/load/comment_1/load_out.json view
@@ -0,0 +1,1 @@+{"key 1":["value 1","value 2"]}
+ vendor/github.com/0y2k/fractaltext-test/load/dict_1/load_in.ft view
@@ -0,0 +1,8 @@+:key 1+    value 1+:key 2+    value 2-1+    value 2-2+:key 3+    ""+    value 3-2
+ vendor/github.com/0y2k/fractaltext-test/load/dict_1/load_out.json view
@@ -0,0 +1,1 @@+{"key 1":["value 1"],"key 2":["value 2-1","value 2-2"],"key 3":["","value 3-2"]}
+ vendor/github.com/0y2k/fractaltext-test/load/dict_2/load_err.json view
@@ -0,0 +1,1 @@+{"line":3}
+ vendor/github.com/0y2k/fractaltext-test/load/dict_2/load_in.ft view
@@ -0,0 +1,3 @@+:key 1+    value 1+      value 2
+ vendor/github.com/0y2k/fractaltext-test/load/dict_3/load_err.json view
@@ -0,0 +1,1 @@+{"line":3}
+ vendor/github.com/0y2k/fractaltext-test/load/dict_3/load_in.ft view
@@ -0,0 +1,3 @@+:key 1+    value 1+  value 2
+ vendor/github.com/0y2k/fractaltext-test/load/list_1/load_in.ft view
@@ -0,0 +1,3 @@+line 1+""+line 3
+ vendor/github.com/0y2k/fractaltext-test/load/list_1/load_out.json view
@@ -0,0 +1,1 @@+["line 1","","line 3"]
+ vendor/github.com/0y2k/fractaltext-test/load/order_1/load_in.ft view
@@ -0,0 +1,4 @@+:order 2+  value 1+:order 1+  value 2
+ vendor/github.com/0y2k/fractaltext-test/load/order_1/load_out.json view
@@ -0,0 +1,1 @@+{"order 2":["value 1"],"order 1":["value 2"]}
+ vendor/github.com/0y2k/fractaltext-test/load/quote_1/load_in.ft view
@@ -0,0 +1,6 @@+:key1+    " value1+:key2+    value2 "+:key3+    "value3"
+ vendor/github.com/0y2k/fractaltext-test/load/quote_1/load_out.json view
@@ -0,0 +1,1 @@+{"key1":["\" value1"],"key2":["value2 \""],"key3":["value3"]}