module LText.Document where
import LText.Expr
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as LT
import Data.Monoid
import Data.Char
import Data.List.Extra (unsnoc)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import System.IO
import System.Exit
import GHC.Generics
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import Test.QuickCheck.Combinators
data Document = Document
{ documentArity :: [Text]
, documentBody :: [DocumentBody]
} deriving (Show, Eq)
instance Arbitrary Document where
arbitrary = do
(Between hs) <- arbitrary `suchThat` (all (all isAlphaNum))
:: Gen (Between 1 5 [] (Between 1 5 [] Char))
(Between body) <- arbitrary :: Gen (Between 1 10 [] DocumentBody)
pure $ Document (LT.pack . getBetween <$> hs) body
data DocumentBody
= RawText [Text]
| Expression Expr
deriving (Show, Eq)
instance Arbitrary DocumentBody where
arbitrary = do
oneof [ do (Between ls) <- arbitrary `suchThat` (all (all isAlphaNum))
:: Gen (Between 1 10 [] (Between 1 10 [] Char))
pure . RawText $ (LT.pack . getBetween) <$> ls
, Expression <$> arbitrary
]
shrink (Expression e) = Expression <$> shrink e
shrink (RawText ts) = RawText <$> shrink ts
repackDocument :: [DocumentBody] -> [DocumentBody]
repackDocument ds =
foldl go [] ds
where
go :: [DocumentBody] -> DocumentBody -> [DocumentBody]
go acc l =
case unsnoc acc of
Just (acc', RawText t) ->
case l of
RawText t' -> acc' ++ [RawText $! t ++ t']
_ -> acc ++ [l]
_ -> acc ++ [l]
parseDocument :: MonadParse m => LT.Text -> m (Document, Maybe (Text, Text))
parseDocument ts =
case LT.lines ts of
[] -> pure (Document [] [], Nothing)
(head':body) ->
case parseHead head' of
Nothing -> pure (Document [] [RawText $! head':body], Nothing)
Just (l,r,hs) ->
let go :: MonadParse m => [DocumentBody] -> Text -> m [DocumentBody]
go acc b =
case findExpression l r b of
Just ts' -> do
e <- liftIO . runParse $ LT.toStrict ts'
pure $ acc ++ [Expression e]
Nothing ->
case unsnoc acc of
Just (acc', RawText b') ->
pure $ acc' ++ [RawText $! b' ++ [b]]
_ ->
pure $ acc ++ [RawText [b]]
in do d <- Document hs <$> foldM go [] body
pure (d, Just (l,r))
where
findExpression :: Text -> Text -> Text -> Maybe Text
findExpression l r ts' =
case LT.words ts' of
[] -> Nothing
[_] -> Nothing
[_,_] -> Nothing
(l':ts'')
| l' /= l -> Nothing
| otherwise -> do
(ts''',r') <- unsnoc ts''
guard $ r' == r
Just $ LT.unwords ts'''
parseHead :: LT.Text -> Maybe (Text, Text, [Text])
parseHead h =
case LT.words h of
[] -> Nothing
[_] -> Nothing
[_,_] -> Nothing
(l:hs) -> case unsnoc hs of
Nothing -> error "impossible state"
Just (hs',r) -> Just (l, r, hs')
printDocument :: MonadPrettyPrint m => Maybe (Text, Text) -> Document -> m Text
printDocument mds (Document head' body) = do
bs <- concat <$> mapM go body
case head' of
[] -> pure $ LT.unlines bs
_ ->
case mds of
Nothing -> throwM NoExplicitDelimiters
Just (ld,rd) ->
pure . LT.unlines $
LT.unwords (ld : (head' ++ [rd]))
: bs
where
go :: MonadPrettyPrint m => DocumentBody -> m [Text]
go (RawText t) = pure t
go (Expression e) =
case mds of
Nothing -> throwM NoExplicitDelimiters
Just (ld,rd) -> do
e' <- LT.pack <$> ppExpr e
pure [ld <> " " <> e' <> " " <> rd]
fromDocument :: Document -> Expr
fromDocument (Document head' body) =
foldr (Abs . LT.unpack) (go body) head'
where
go (RawText t:[]) = Lit t
go (RawText t:ts) = Concat (Lit t) (go ts)
go (Expression e:[]) = e
go (Expression e:ts) = Concat e (go ts)
go _ = error "Text file without any text"
data PrintError
= ConcatExprText Expr
| NoExplicitDelimiters
deriving (Show, Eq, Generic)
instance Exception PrintError
handlePrintError :: PrintError -> IO a
handlePrintError e = do
hPutStrLn stderr $
case e of
ConcatExprText ex ->
"[Print Error] Can't print textual data while residually inside an expression: "
++ show (subLit ex)
NoExplicitDelimiters ->
"[Print Error] Can't render a document with residual arity without explicit\
\ --left and --right delimiters"
exitFailure
where
subLit :: Expr -> Expr
subLit (Lit _) = Lit ["###"]
subLit (App e1 e2) = App (subLit e1) (subLit e2)
subLit (Concat e1 e2) = Concat (subLit e1) (subLit e2)
subLit (Var n) = Var n
subLit (Abs n e') = Abs n (subLit e')
toDocument :: MonadThrow m => Expr -> m Document
toDocument e =
if not $ isPrintable e
then throwM $ ConcatExprText e
else case getInitArity e of
(hs,e') -> pure . Document hs $ getBody e'
where
getBody :: Expr -> [DocumentBody]
getBody e' =
case e' of
Lit t -> [RawText t]
Concat e1 e2 -> getBody e1 ++ getBody e2
e'' -> [Expression e'']
getInitArity :: Expr -> ([Text], Expr)
getInitArity e' =
case e' of
Abs n e'' -> let (hs , e''') = getInitArity e''
in (LT.pack n:hs, e''')
e'' -> ([], e'')
isPrintable :: Expr -> Bool
isPrintable = not . hasConcatAbsLit
hasConcatAbsLit :: Expr -> Bool
hasConcatAbsLit = go Nothing
where
go :: Maybe PrintabilityMode -> Expr -> Bool
go Nothing e =
case e of
Var _ -> False
Lit _ -> False
Abs _ e' -> go Nothing e'
App e1 e2 -> go Nothing e1 || go Nothing e2
Concat e1 e2 -> go (Just InsideConcat) e1
|| go (Just InsideConcat) e2
go (Just InsideConcat) e =
case e of
Lit _ -> False
Var _ -> False
Abs _ e' -> go (Just InsideExpr) e'
App e1 e2 -> go (Just InsideExpr) e1
|| go (Just InsideExpr) e2
Concat e1 e2 -> go (Just InsideConcat) e1
|| go (Just InsideConcat) e2
go (Just InsideExpr) e =
case e of
Lit _ -> True
Concat _ _ -> True
Var _ -> False
Abs _ e' -> go (Just InsideExpr) e'
App e1 e2 -> go (Just InsideExpr) e1
|| go (Just InsideExpr) e2
data PrintabilityMode
= InsideConcat
| InsideExpr
fetchDocument :: FilePath -> IO Expr
fetchDocument f = do
txt <- LT.readFile f
(d,_) <- runParserT $ parseDocument txt
pure $ fromDocument d
rawDocument :: FilePath -> IO Expr
rawDocument f = do
txts <- LT.lines <$> LT.readFile f
pure $ Lit txts