Add HTML5 rendition of Head.

[doclang.git] / Language / TCT / Read / Cell.hs

diff --git a/Language/TCT/Read/Cell.hs b/Language/TCT/Read/Cell.hs
index 76a600ee38a4c2dde78310d22d17e0ccf6d799e8..602d7ce3f2372d048feaf12ff6e2c088824a4591 100644 (file)
--- a/Language/TCT/Read/Cell.hs
+++ b/Language/TCT/Read/Cell.hs
@@ -1,33 +1,47 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE TypeFamilies #-}
 module Language.TCT.Read.Cell where
 
+import Control.Applicative (Applicative(..))
 import Data.Char (Char)
 import Data.Either (Either(..))
+import Data.Eq (Eq)
 import Data.Function (($), (.))
 import Data.Functor ((<$>))
-import Data.Int (Int)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (Maybe(..))
 import Data.Ord (Ord)
-import Data.String (String, IsString)
-import Prelude (Num(..), toInteger)
-import Text.Show (Show)
+import Data.Proxy (Proxy(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (IsString)
+import Data.Tuple (snd)
+import System.FilePath (FilePath)
 import qualified Data.Set as Set
+import qualified Data.Text.Lazy as TL
 import qualified Text.Megaparsec as P
 
 import Language.TCT.Cell
+import Language.TCT.Debug
 
 -- * Type 'Parser'
 -- | Convenient alias.
-type Parser e s a =
+type Parser   e s a =
+     Parsable e s a =>
+     P.Parsec e s a
+
+-- ** Type 'Parsable'
+type Parsable e s a =
  ( P.Stream s
  , P.Token s ~ Char
  , Ord e
  , IsString (P.Tokens s)
- ) => P.Parsec e s a
+ , P.ShowErrorComponent e
+ )
 
+-- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
 p_satisfyMaybe f = check `P.token` Nothing
        where
@@ -39,23 +53,60 @@ p_satisfyMaybe f = check `P.token` Nothing
 p_Position :: Parser e s Pos
 p_Position = (<$> P.getPosition) $ \p ->
        Pos
-        (intOfPos $ P.sourceLine p)
-        (intOfPos $ P.sourceColumn p)
-intOfPos :: P.Pos -> Int
-intOfPos = fromInteger . toInteger . P.unPos
-
-p_LineNum :: Parser e s Line
-p_LineNum = intOfPos . P.sourceLine <$> P.getPosition
-
-p_ColNum :: Parser e s Column
-p_ColNum = intOfPos . P.sourceColumn <$> P.getPosition
-
--- * Debug
-pdbg :: ( Show a
-        , P.Token s ~ Char
-        , P.ShowToken (P.Token s)
-        , P.Stream s
-        ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
--- pdbg m p = P.dbg m p
-pdbg _m p = p
-{-# INLINE pdbg #-}
+        { pos_line   = P.unPos $ P.sourceLine p
+        , pos_column = P.unPos $ P.sourceColumn p
+        }
+
+p_Cell :: Parser e s a -> Parser e s (Cell a)
+p_Cell pa =
+       (\b a e -> Cell b e a)
+        <$> p_Position
+        <*> pa
+        <*> p_Position
+
+p_LineNum :: Parser e s LineNum
+p_LineNum = P.unPos . P.sourceLine <$> P.getPosition
+
+p_ColNum :: Parser e s ColNum
+p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition
+
+-- | Wrapper around |P.runParser'|
+-- to use given 'Cell' as starting position.
+runParserOnCell ::
+ Parsable e StreamCell a =>
+ FilePath ->
+ Parser e StreamCell a ->
+ Cell TL.Text ->
+ Either (P.ParseError (P.Token StreamCell) e) a
+runParserOnCell inp p (Cell bp _ep s) =
+       snd $ P.runParser' (p <* P.eof)
+        P.State
+        { P.stateInput    = StreamCell s
+        , P.statePos      = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
+        , P.stateTabWidth = indent
+        , P.stateTokensProcessed = 0
+        }
+       where indent = debug0 "runParserOnCell: indent" $ P.mkPos $ pos_column bp
+
+-- * Type 'StreamCell'
+-- | Wrap 'TL.Text' to have a 'P.Stream' instance
+-- whose 'P.advance1' method abuses the tab width state
+-- to instead pass the line indent.
+-- This in order to report correct 'P.SourcePos'
+-- when parsing a 'Cell' containing newlines.
+newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
+ deriving (IsString,Eq,Ord)
+instance P.Stream StreamCell where
+       type Token  StreamCell = Char
+       type Tokens StreamCell = TL.Text
+       take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
+       takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
+       takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
+       tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
+       chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
+       chunkLength   _s = P.chunkLength   (Proxy::Proxy TL.Text)
+       advance1 _s indent (P.SourcePos n line col) c =
+               case c of
+                '\n' -> P.SourcePos n (line <> P.pos1) indent
+                _    -> P.SourcePos n line (col <> P.pos1)
+       advanceN s indent = TL.foldl' (P.advance1 s indent)