{-# LANGUAGE
    FlexibleContexts
  , OverloadedStrings
  , DeriveGeneric
  , DataKinds
  , NamedFieldPuns
  , RecordWildCards
  , LambdaCase
  #-}

module LText.Document where

import LText.Expr (Expr (..), MonadParse, MonadPrettyPrint, runParserT, runParse, ppExpr)

import           Data.Text.Lazy       (Text)
import qualified Data.Text.Lazy    as LT
import qualified Data.Text.Lazy.IO as LT

import Data.Char (isAlphaNum)
import Data.List.Extra (unsnoc)
import Control.Monad (guard, foldM)
import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Control.Monad.IO.Class (liftIO)

import System.IO (stderr, hPutStrLn)
import System.Exit (exitFailure)
import GHC.Generics (Generic)

import Test.QuickCheck (Arbitrary (shrink, arbitrary), suchThat, oneof, listOf1)
import Test.QuickCheck.Instances ()


-- | A parsed document
data Document = Document
  { Document -> [Text]
documentArity :: [Text]
    -- ^ Arity of the document - the parameters of the function, where each
    -- entry is the name of the term.
  , Document -> [DocumentBody]
documentBody  :: [DocumentBody]
    -- ^ The function's body
  } deriving (Int -> Document -> ShowS
[Document] -> ShowS
Document -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Document] -> ShowS
$cshowList :: [Document] -> ShowS
show :: Document -> String
$cshow :: Document -> String
showsPrec :: Int -> Document -> ShowS
$cshowsPrec :: Int -> Document -> ShowS
Show, Document -> Document -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Document -> Document -> Bool
$c/= :: Document -> Document -> Bool
== :: Document -> Document -> Bool
$c== :: Document -> Document -> Bool
Eq)

instance Arbitrary Document where
  arbitrary :: Gen Document
arbitrary = do
    [Text]
documentArity <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
LT.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall a. Gen a -> Gen [a]
listOf1 (forall a. Gen a -> Gen [a]
listOf1 (forall a. Arbitrary a => Gen a
arbitrary forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Char -> Bool
isAlphaNum))
    [DocumentBody]
documentBody <- forall a. Gen a -> Gen [a]
listOf1 forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Document {[Text]
documentArity :: [Text]
documentArity :: [Text]
documentArity, [DocumentBody]
documentBody :: [DocumentBody]
documentBody :: [DocumentBody]
documentBody}
 -- shrink (Document hs body) =
 --   Document <$> shrink hs <*> shrink body


-- | The body of a document is either a block of raw text, or an ltext expression.
data DocumentBody
  = RawText [Text]
  | Expression Expr
  deriving (Int -> DocumentBody -> ShowS
[DocumentBody] -> ShowS
DocumentBody -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DocumentBody] -> ShowS
$cshowList :: [DocumentBody] -> ShowS
show :: DocumentBody -> String
$cshow :: DocumentBody -> String
showsPrec :: Int -> DocumentBody -> ShowS
$cshowsPrec :: Int -> DocumentBody -> ShowS
Show, DocumentBody -> DocumentBody -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocumentBody -> DocumentBody -> Bool
$c/= :: DocumentBody -> DocumentBody -> Bool
== :: DocumentBody -> DocumentBody -> Bool
$c== :: DocumentBody -> DocumentBody -> Bool
Eq)

instance Arbitrary DocumentBody where
  arbitrary :: Gen DocumentBody
arbitrary = forall a. [Gen a] -> Gen a
oneof
    [ do
      [String]
ls <- forall a. Gen a -> Gen [a]
listOf1 (forall a. Gen a -> Gen [a]
listOf1 (forall a. Arbitrary a => Gen a
arbitrary forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Char -> Bool
isAlphaNum))
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> DocumentBody
RawText forall a b. (a -> b) -> a -> b
$ String -> Text
LT.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
ls
    , Expr -> DocumentBody
Expression forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
    ]
  shrink :: DocumentBody -> [DocumentBody]
shrink (Expression Expr
e) = Expr -> DocumentBody
Expression forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink Expr
e
  shrink (RawText [Text]
ts)   = [Text] -> DocumentBody
RawText    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink [Text]
ts


-- | Concatenates adjacent 'RawText' blocks
repackDocument :: [DocumentBody] -> [DocumentBody]
repackDocument :: [DocumentBody] -> [DocumentBody]
repackDocument [DocumentBody]
ds =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [DocumentBody] -> DocumentBody -> [DocumentBody]
go [] [DocumentBody]
ds
  where
    go :: [DocumentBody] -> DocumentBody -> [DocumentBody]
    go :: [DocumentBody] -> DocumentBody -> [DocumentBody]
go [DocumentBody]
acc DocumentBody
l =
      case (forall a. [a] -> Maybe ([a], a)
unsnoc [DocumentBody]
acc, DocumentBody
l) of
        (Just ([DocumentBody]
acc', RawText [Text]
t), RawText [Text]
t') -> [DocumentBody]
acc' forall a. [a] -> [a] -> [a]
++ [[Text] -> DocumentBody
RawText forall a b. (a -> b) -> a -> b
$! [Text]
t forall a. [a] -> [a] -> [a]
++ [Text]
t']
        (Maybe ([DocumentBody], DocumentBody), DocumentBody)
_ -> [DocumentBody]
acc forall a. [a] -> [a] -> [a]
++ [DocumentBody
l]


-- | Takes a raw text file and returns the parsed document, and left and right delimiters if it
-- has arity.
parseDocument :: MonadParse m
              => LT.Text -- ^ Document content
              -> m (Document, Maybe (Text, Text))
parseDocument :: forall (m :: * -> *).
MonadParse m =>
Text -> m (Document, Maybe (Text, Text))
parseDocument Text
ts =
  case Text -> [Text]
LT.lines Text
ts of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document {documentArity :: [Text]
documentArity = [], documentBody :: [DocumentBody]
documentBody = []}, forall a. Maybe a
Nothing)
    bodyWithHead :: [Text]
bodyWithHead@(Text
head':[Text]
body) ->
      case Text -> Maybe (Text, Text, [Text])
parseHead Text
head' of
        Maybe (Text, Text, [Text])
Nothing ->
          -- Document has 0 arity
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document {documentArity :: [Text]
documentArity = [], documentBody :: [DocumentBody]
documentBody = [[Text] -> DocumentBody
RawText [Text]
bodyWithHead]}, forall a. Maybe a
Nothing)
        Just (Text
l, Text
r, [Text]
documentArity) ->
          let go :: MonadParse m => [DocumentBody] -> Text -> m [DocumentBody]
              go :: forall (m :: * -> *).
MonadParse m =>
[DocumentBody] -> Text -> m [DocumentBody]
go [DocumentBody]
acc Text
b =
                case Text -> Maybe Text
findExpression Text
b of
                  -- if an expression exists, parse it
                  Just Text
ts' -> do
                    Expr
e <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO Expr
runParse forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict Text
ts'
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [DocumentBody]
acc forall a. [a] -> [a] -> [a]
++ [Expr -> DocumentBody
Expression Expr
e]

                  Maybe Text
Nothing ->
                    case forall a. [a] -> Maybe ([a], a)
unsnoc [DocumentBody]
acc of
                      -- Add this line of text to the previous block, if it was text as well
                      Just ([DocumentBody]
acc', RawText [Text]
b') ->
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [DocumentBody]
acc' forall a. [a] -> [a] -> [a]
++ [[Text] -> DocumentBody
RawText forall a b. (a -> b) -> a -> b
$! [Text]
b' forall a. [a] -> [a] -> [a]
++ [Text
b]]
                      Maybe ([DocumentBody], DocumentBody)
_ ->
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [DocumentBody]
acc  forall a. [a] -> [a] -> [a]
++ [[Text] -> DocumentBody
RawText [Text
b]]
                where
                  -- Determines whether or not a line has an expression within it, and extracts it
                  findExpression :: Text -> Maybe Text
                  findExpression :: Text -> Maybe Text
findExpression Text
ts' =
                    case Text -> [Text]
LT.words Text
ts' of
                      []    -> forall a. Maybe a
Nothing
                      [Text
_]   -> forall a. Maybe a
Nothing
                      [Text
_,Text
_] -> forall a. Maybe a
Nothing
                      (Text
l':[Text]
ts'') -> do
                        ([Text]
ts''',Text
r') <- forall a. [a] -> Maybe ([a], a)
unsnoc [Text]
ts''
                        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
r' forall a. Eq a => a -> a -> Bool
== Text
r Bool -> Bool -> Bool
&& Text
l' forall a. Eq a => a -> a -> Bool
== Text
l
                        -- FIXME why did I undo the tokens?
                        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LT.unwords [Text]
ts'''
          in  do [DocumentBody]
documentBody <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall (m :: * -> *).
MonadParse m =>
[DocumentBody] -> Text -> m [DocumentBody]
go [] [Text]
body
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document {[Text]
documentArity :: [Text]
documentArity :: [Text]
documentArity, [DocumentBody]
documentBody :: [DocumentBody]
documentBody :: [DocumentBody]
documentBody}, forall a. a -> Maybe a
Just (Text
l,Text
r))
  where

    -- interprets the first line of a document into its left delimiter, right delimiter, and
    -- parameters, respectively.
    parseHead :: LT.Text -> Maybe (Text, Text, [Text])
    parseHead :: Text -> Maybe (Text, Text, [Text])
parseHead Text
h =
      case Text -> [Text]
LT.words Text
h of
        []    -> forall a. Maybe a
Nothing
        [Text
_]   -> forall a. Maybe a
Nothing
        [Text
_,Text
_] -> forall a. Maybe a
Nothing
        (Text
l:[Text]
hs) -> case forall a. [a] -> Maybe ([a], a)
unsnoc [Text]
hs of
          Maybe ([Text], Text)
Nothing      -> forall a. HasCallStack => String -> a
error String
"impossible state"
          Just ([Text]
hs',Text
r) -> forall a. a -> Maybe a
Just (Text
l, Text
r, [Text]
hs')



printDocument :: MonadPrettyPrint m
              => Maybe (Text, Text) -- ^ Explicitly supplied delimiters
              -> Document -> m Text
printDocument :: forall (m :: * -> *).
MonadPrettyPrint m =>
Maybe (Text, Text) -> Document -> m Text
printDocument Maybe (Text, Text)
mds Document{[Text]
[DocumentBody]
documentBody :: [DocumentBody]
documentArity :: [Text]
documentBody :: Document -> [DocumentBody]
documentArity :: Document -> [Text]
..} = do
  [Text]
bs <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadPrettyPrint m =>
DocumentBody -> m [Text]
go [DocumentBody]
documentBody
  case [Text]
documentArity of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LT.unlines [Text]
bs
    [Text]
_ ->
      case Maybe (Text, Text)
mds of
        Maybe (Text, Text)
Nothing      -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrintError
NoExplicitDelimiters
        Just (Text
ld,Text
rd) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
LT.unlines forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
LT.unwords (Text
ld forall a. a -> [a] -> [a]
: ([Text]
documentArity forall a. [a] -> [a] -> [a]
++ [Text
rd])) forall a. a -> [a] -> [a]
: [Text]
bs
  where
    go :: MonadPrettyPrint m => DocumentBody -> m [Text]
    go :: forall (m :: * -> *).
MonadPrettyPrint m =>
DocumentBody -> m [Text]
go (RawText [Text]
t)    = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
t
    go (Expression Expr
e) =
      case Maybe (Text, Text)
mds of
        Maybe (Text, Text)
Nothing      -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrintError
NoExplicitDelimiters
        Just (Text
ld,Text
rd) -> do
          -- expressions are pretty printed, then placed within delimiters
          Text
e' <- String -> Text
LT.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPrettyPrint m => Expr -> m String
ppExpr Expr
e
          forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
ld forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
e' forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
rd]


-- | Given a document, generate an expression (without thinking too hard about it)
fromDocument :: FilePath -- ^ Name of source file
             -> Document
             -> Expr
fromDocument :: String -> Document -> Expr
fromDocument String
source Document{[Text]
[DocumentBody]
documentBody :: [DocumentBody]
documentArity :: [Text]
documentBody :: Document -> [DocumentBody]
documentArity :: Document -> [Text]
..} =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> Expr -> Expr
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LT.unpack) ([DocumentBody] -> Expr
go [DocumentBody]
documentBody) [Text]
documentArity
  where
    go :: [DocumentBody] -> Expr
go (RawText [Text]
t:[DocumentBody]
ts)    = Expr -> Expr -> String -> Bool -> Expr
Concat ([Text] -> String -> Bool -> Expr
Lit [Text]
t String
source Bool
False) ([DocumentBody] -> Expr
go [DocumentBody]
ts) String
source Bool
False
    go (Expression Expr
e:[DocumentBody]
ts) = Expr -> Expr -> String -> Bool -> Expr
Concat Expr
e ([DocumentBody] -> Expr
go [DocumentBody]
ts) String
source Bool
False
    go [RawText [Text]
t]       = [Text] -> String -> Bool -> Expr
Lit [Text]
t String
source Bool
False
    go [Expression Expr
e]    = Expr
e
    go []                = [Text] -> String -> Bool -> Expr
Lit [] String
source Bool
False


data PrintError
  = ConcatExprText Expr -- ^ Represents a scenario where a 'Lit' is inside a 'Abs' or 'App'.
  | NoExplicitDelimiters
  deriving (Int -> PrintError -> ShowS
[PrintError] -> ShowS
PrintError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrintError] -> ShowS
$cshowList :: [PrintError] -> ShowS
show :: PrintError -> String
$cshow :: PrintError -> String
showsPrec :: Int -> PrintError -> ShowS
$cshowsPrec :: Int -> PrintError -> ShowS
Show, PrintError -> PrintError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrintError -> PrintError -> Bool
$c/= :: PrintError -> PrintError -> Bool
== :: PrintError -> PrintError -> Bool
$c== :: PrintError -> PrintError -> Bool
Eq, forall x. Rep PrintError x -> PrintError
forall x. PrintError -> Rep PrintError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PrintError x -> PrintError
$cfrom :: forall x. PrintError -> Rep PrintError x
Generic)

instance Exception PrintError

data PrintabilityMode
  = InsideConcat
  | InsideExpr


decorateUnprintable :: Expr -> Expr
decorateUnprintable :: Expr -> Expr
decorateUnprintable = Maybe PrintabilityMode -> Expr -> Expr
go forall a. Maybe a
Nothing
  where
    go :: Maybe PrintabilityMode -> Expr -> Expr
go Maybe PrintabilityMode
Nothing = \case
      Concat Expr
e1 Expr
e2 String
s Bool
_ ->
        Expr -> Expr -> String -> Bool -> Expr
Concat (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideConcat) Expr
e1) (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideConcat) Expr
e2) String
s Bool
False
      Abs String
n Expr
e ->
        String -> Expr -> Expr
Abs String
n (Maybe PrintabilityMode -> Expr -> Expr
go forall a. Maybe a
Nothing Expr
e)
      App Expr
e1 Expr
e2 ->
        Expr -> Expr -> Expr
App (Maybe PrintabilityMode -> Expr -> Expr
go forall a. Maybe a
Nothing Expr
e1) (Maybe PrintabilityMode -> Expr -> Expr
go forall a. Maybe a
Nothing Expr
e2)
      Expr
e -> Expr
e
    go (Just PrintabilityMode
InsideConcat) = \case
      Concat Expr
e1 Expr
e2 String
s Bool
_ ->
        Expr -> Expr -> String -> Bool -> Expr
Concat (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideConcat) Expr
e1) (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideConcat) Expr
e2) String
s Bool
False
      Abs String
n Expr
e ->
        String -> Expr -> Expr
Abs String
n (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideExpr) Expr
e)
      App Expr
e1 Expr
e2 ->
        Expr -> Expr -> Expr
App (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideExpr) Expr
e1) (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideExpr) Expr
e2)
      Expr
e -> Expr
e
    go (Just PrintabilityMode
InsideExpr) = \case
      Concat Expr
l Expr
r String
s Bool
_ -> Expr -> Expr -> String -> Bool -> Expr
Concat Expr
l Expr
r String
s Bool
True
      Lit [Text]
t String
s Bool
_ -> [Text] -> String -> Bool -> Expr
Lit [Text]
t String
s Bool
True
      Abs String
n Expr
e -> String -> Expr -> Expr
Abs String
n (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideExpr) Expr
e)
      App Expr
e1 Expr
e2 -> Expr -> Expr -> Expr
App (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideExpr) Expr
e1) (Maybe PrintabilityMode -> Expr -> Expr
go (forall a. a -> Maybe a
Just PrintabilityMode
InsideExpr) Expr
e2)
      Expr
e -> Expr
e

isAnyUnprintable :: Expr -> Bool
isAnyUnprintable :: Expr -> Bool
isAnyUnprintable = \case
  Concat Expr
_ Expr
_ String
_ Bool
True -> Bool
True
  Lit [Text]
_ String
_ Bool
True -> Bool
True
  Concat Expr
e1 Expr
e2 String
_ Bool
_ -> Expr -> Bool
isAnyUnprintable Expr
e1 Bool -> Bool -> Bool
|| Expr -> Bool
isAnyUnprintable Expr
e2
  Abs String
_ Expr
e -> Expr -> Bool
isAnyUnprintable Expr
e
  App Expr
e1 Expr
e2 -> Expr -> Bool
isAnyUnprintable Expr
e1 Bool -> Bool -> Bool
|| Expr -> Bool
isAnyUnprintable Expr
e2
  Expr
_ -> Bool
False

handlePrintError :: PrintError -> IO a
handlePrintError :: forall a. PrintError -> IO a
handlePrintError PrintError
e = do
  case PrintError
e of
    ConcatExprText Expr
ex -> do
      String
err <- forall (m :: * -> *). MonadPrettyPrint m => Expr -> m String
ppExpr (Expr -> Expr
decorateUnprintable Expr
ex)
      Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"[Print Error] Can't print textual data while inside an expression: \n\n"
        forall a. [a] -> [a] -> [a]
++ String
err forall a. [a] -> [a] -> [a]
++ String
"\n\n...cannot be rendered to a file."
    PrintError
NoExplicitDelimiters ->
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"[Print Error] Can't render a document with arity without explicit --left and --right delimiters"
  forall a. IO a
exitFailure



toDocument :: MonadThrow m => Expr -> m Document
toDocument :: forall (m :: * -> *). MonadThrow m => Expr -> m Document
toDocument Expr
e =
  if Expr -> Bool
isAnyUnprintable (Expr -> Expr
decorateUnprintable Expr
e)
  then forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Expr -> PrintError
ConcatExprText Expr
e
  else case Expr -> ([Text], Expr)
getInitArity Expr
e of
    ([Text]
documentArity, Expr
e') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Document {[Text]
documentArity :: [Text]
documentArity :: [Text]
documentArity, documentBody :: [DocumentBody]
documentBody = Expr -> [DocumentBody]
getBody Expr
e'}
  where
    getBody :: Expr -> [DocumentBody]
    getBody :: Expr -> [DocumentBody]
getBody =
      \case
        Lit [Text]
t String
_ Bool
_    -> [[Text] -> DocumentBody
RawText [Text]
t]
        Concat Expr
e1 Expr
e2 String
_ Bool
_ -> Expr -> [DocumentBody]
getBody Expr
e1 forall a. [a] -> [a] -> [a]
++ Expr -> [DocumentBody]
getBody Expr
e2
        Expr
e''          -> [Expr -> DocumentBody
Expression Expr
e'']

    -- Extracts the top-level parameters from an expression, if it's an abstraction
    getInitArity :: Expr -> ([Text], Expr)
    getInitArity :: Expr -> ([Text], Expr)
getInitArity =
      \case
        Abs String
n Expr
e'' -> let ([Text]
hs          , Expr
e''') = Expr -> ([Text], Expr)
getInitArity Expr
e''
                     in  (String -> Text
LT.pack String
nforall a. a -> [a] -> [a]
:[Text]
hs, Expr
e''')
        Expr
e'        -> ([], Expr
e')


fetchDocument :: FilePath -> IO Expr
fetchDocument :: String -> IO Expr
fetchDocument String
f = do
  Text
txt   <- String -> IO Text
LT.readFile String
f
  (Document
d,Maybe (Text, Text)
_) <- forall a. StateT ParseState IO a -> IO a
runParserT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadParse m =>
Text -> m (Document, Maybe (Text, Text))
parseDocument Text
txt
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Document -> Expr
fromDocument String
f Document
d

rawDocument :: FilePath -> IO Expr
rawDocument :: String -> IO Expr
rawDocument String
f = do
  [Text]
txts <- Text -> [Text]
LT.lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
LT.readFile String
f
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> String -> Bool -> Expr
Lit [Text]
txts String
f Bool
False