A simple script for converting literate code to code.

Unlit.lhs

> {-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections, DeriveFunctor #-}
> module Unlit where



> import           Control.Arrow (first,second)
> import           Data.List (foldl')
> import           Data.Text (Text)
> import qualified Data.Text    as T
> import qualified Data.Text.IO as T
> import           Data.Void (Void,absurd)


> data State st
>    = Start
>    | Other st
>    deriving (Eq,Functor)


> data Change a
>    = Cert   a
>    | Poss   a
>    deriving (Eq,Functor)


> runChange :: Change a -> a
> runChange (Cert x) = x
> runChange (Poss x) = x


> choose :: (Eq a) => Change a -> Change a -> Change a
> choose (Cert x)       _           = Cert x
> choose       _  (Cert y)          = Cert y
> choose (Poss x) (Poss y) | x == y = Poss x
> choose       _        _           =
>   error "choose: one or more styles do not satisfy the required laws"

We can define unlitting styles as stepping functions, which take
the current state, and return a suggested new line, together with a
new state, wrapped in a `Change`:

> newtype Style st s = Style
>   { step :: State st -> s -> Change (s, State st) }

These stepping functions should satisfy the following law: *if*
`step Start` does anything other than strip the line (as `spaces
ln`), *then* it should be certain about it---i.e. it should wrap its
result in `Cert`, not in `Poss`.
If this is the case, then the `choose` function above covers all
cases.

Simple transition functions, with only a single state, can easily be
encoded as unlitting styles, using the `Void` type for the additional
states:

> simple :: (s -> Change s) -> Style Void s
> simple f = Style{..}
>   where
>     step  Start     ln = fmap (,Start) (f ln)
>     step (Other st) _  = absurd st

We can easily merge unlitting styles, by joining their sets of their
states using `Either`:

> andThen :: (Eq st1, Eq st2, Eq s) => Style st1 s -> Style st2 s -> Style (Either st1 st2) s
> andThen (Style step1) (Style step2) = Style step
>   where
>
>     inl = fmap ( second $ fmap Left  )
>     inr = fmap ( second $ fmap Right )
>
>     step Start ln = inl (step1 Start ln) `choose` inr (step2 Start ln)
>     step (Other (Left  st1)) ln = inl (step1 (Other st1) ln)
>     step (Other (Right st2)) ln = inr (step2 (Other st2) ln)


> runStyle :: Style st Text -> Text -> Text
> runStyle Style{..} = fst . foldl' go ("", Start) . T.lines
>   where
>     go (text, st) ln =
>       first (\ln' -> T.append text (T.snoc ln' '\n')) (runChange (step st ln))



> birdStyle :: Style Void Text
> birdStyle =
>   simple (\ln -> maybe (Poss (spaces ln)) (Cert . T.cons ' ') (T.stripPrefix ">" ln))



> data LaTeX = InLaTeXCB deriving (Eq)

> latexStyle    :: Style LaTeX Text
> latexStyle    = fencedStyle "\\begin{code}" "\\end{code}" InLaTeXCB



> haskellStyle  :: Style (Either Void LaTeX) Text
> haskellStyle  = birdStyle `andThen` latexStyle



> type Markdown = Either Tilde Backtick
> data Tilde    = InTildeCB    deriving (Eq)
> data Backtick = InBacktickCB deriving (Eq)

> markdownStyle :: Style Markdown Text
> markdownStyle = tildeStyle `andThen` backtickStyle
>   where
>     tildeStyle    = fencedStyle "~~~" "~~~" InTildeCB
>     backtickStyle = fencedStyle "```" "```" InBacktickCB



> data OrgMode = InOrgModeCB deriving (Eq)

> orgModeStyle :: Style OrgMode Text
> orgModeStyle = fencedStyle "#+BEGIN_SRC" "#+END_SRC" InOrgModeCB



> fencedStyle :: (Eq st) => Text -> Text -> st -> Style st Text
> fencedStyle begin end inCB = Style{..}
>   where
>
>     isBegin, isEnd :: Text -> Bool
>     isBegin = T.isPrefixOf begin . T.stripStart
>     isEnd   = T.isPrefixOf end   . T.stripStart
>
>     step  Start    ln
>       | isBegin ln = Cert (stripTag begin ln, Other inCB)
>       | otherwise  = Poss (spaces ln        , Start     )
>     step (Other st) ln
>       | st == inCB && isEnd ln = Cert (stripTag end ln, Start     )
>       | st == inCB             = Cert (ln             , Other inCB)
>       | otherwise              = Poss (ln             , Other st  )

> spaces :: Text -> Text
> spaces = T.map (const ' ')

> stripTag :: Text -> Text -> Text
> stripTag tag ln = uncurry T.append (second spaces (T.breakOn tag ln))