------------------------------------------------------------------------------- This version is interesting because instead of striping comment lines, it-- turns them into "-- " style comments. This allows using haddock markup-- in literate scripts without having to use "> --" prefix.-- |-- Module : Distribution.Simple.PreProcess.Unlit-- Copyright : ...---- Maintainer : cabal-devel@haskell.org-- Portability : portable---- Remove the \"literal\" markups from a Haskell source file, including-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"moduleDistribution.Simple.PreProcess.Unlit(unlit ,plain )whereimportData.List(mapAccumL)importDistribution.Compat.PreludeimportDistribution.Simple.Errors importDistribution.Utils.Generic(safeInit,safeLast,safeTail)importPrelude()dataClassified =BirdTrack String|Blank String|Ordinary String|Line !IntString|CPP String|BeginCode |EndCode |-- output only:Error String|Comment String-- | No unliteration.plain ::String->String->Stringplain :: String -> String -> String
plain String
_String
hs =String
hs classify ::String->Classified classify :: String -> Classified
classify (Char
'>':String
s )=String -> Classified
BirdTrack String
s classify (Char
'#':String
s )=caseString -> [String]
tokens String
s of(String
line :file :: String
file @(Char
'"':Char
_:String
_):[String]
_)|(Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
allChar -> Bool
isDigitString
line Bool -> Bool -> Bool
&&String -> Maybe Char
forall a. [a] -> Maybe a
safeLastString
file Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char -> Maybe Char
forall a. a -> Maybe a
JustChar
'"'->-- this shouldn't fail as we tested for 'all isDigit'Int -> String -> Classified
Line (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe(String -> Int
forall a. HasCallStack => String -> a
error(String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$String
"panic! read @Int "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
showString
line )(Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybeString
line )(String -> String
forall a. [a] -> [a]
safeTail(String -> String
forall a. [a] -> [a]
safeInitString
file ))-- TODO:eradicateNoParse[String]
_->String -> Classified
CPP String
s wheretokens :: String -> [String]
tokens =(String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr((String -> Maybe (String, String)) -> String -> [String])
-> (String -> Maybe (String, String)) -> String -> [String]
forall a b. (a -> b) -> a -> b
$\String
str ->caseReadS String
lexString
str of(t :: String
t @(Char
_:String
_),String
str' ):[(String, String)]
_->(String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just(String
t ,String
str' )[(String, String)]
_->Maybe (String, String)
forall a. Maybe a
Nothingclassify (Char
'\\':String
s )|String
"begin{code}"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
s =Classified
BeginCode |String
"end{code}"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
s =Classified
EndCode classify String
s |(Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
allChar -> Bool
isSpaceString
s =String -> Classified
Blank String
s classify String
s =String -> Classified
Ordinary String
s -- So the weird exception for comment indenting is to make things work with-- haddock, see classifyAndCheckForBirdTracks below.unclassify ::Bool->Classified ->Stringunclassify :: Bool -> Classified -> String
unclassify Bool
_(BirdTrack String
s )=Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s unclassify Bool
_(Blank String
s )=String
s unclassify Bool
_(Ordinary String
s )=String
s unclassify Bool
_(Line Int
n String
file )=String
"# "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
showInt
n String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
showString
file unclassify Bool
_(CPP String
s )=Char
'#'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s unclassify Bool
True(Comment String
"")=String
" --"unclassify Bool
True(Comment String
s )=String
" -- "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s unclassify Bool
False(Comment String
"")=String
"--"unclassify Bool
False(Comment String
s )=String
"-- "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s unclassify Bool
_Classified
_=String
forall a. a
internalError -- | 'unlit' takes a filename (for error reports), and transforms the-- given string, to eliminate the literate comments from the program text.unlit ::FilePath->String->EitherStringCabalException unlit :: String -> String -> Either String CabalException
unlit String
file String
input =let(Bool
usesBirdTracks ,[Classified]
classified )=[String] -> (Bool, [Classified])
classifyAndCheckForBirdTracks ([String] -> (Bool, [Classified]))
-> (String -> [String]) -> String -> (Bool, [Classified])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> [String]
inlines (String -> (Bool, [Classified])) -> String -> (Bool, [Classified])
forall a b. (a -> b) -> a -> b
$String
input in([Classified] -> Either String CabalException)
-> (CabalException -> Either String CabalException)
-> Either [Classified] CabalException
-> Either String CabalException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either(String -> Either String CabalException
forall a b. a -> Either a b
Left(String -> Either String CabalException)
-> ([Classified] -> String)
-> [Classified]
-> Either String CabalException
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[String] -> String
unlines([String] -> String)
-> ([Classified] -> [String]) -> [Classified] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Classified -> String) -> [Classified] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map(Bool -> Classified -> String
unclassify Bool
usesBirdTracks ))CabalException -> Either String CabalException
forall a b. b -> Either a b
Right(Either [Classified] CabalException
 -> Either String CabalException)
-> ([Classified] -> Either [Classified] CabalException)
-> [Classified]
-> Either String CabalException
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Classified] -> Either [Classified] CabalException
checkErrors ([Classified] -> Either [Classified] CabalException)
-> ([Classified] -> [Classified])
-> [Classified]
-> Either [Classified] CabalException
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Classified] -> [Classified]
reclassify ([Classified] -> Either String CabalException)
-> [Classified] -> Either String CabalException
forall a b. (a -> b) -> a -> b
$[Classified]
classified where-- So haddock requires comments and code to align, since it treats comments-- as following the layout rule. This is a pain for us since bird track-- style literate code typically gets indented by two since ">" is replaced-- by " " and people usually use one additional space of indent ie-- "> then the code". On the other hand we cannot just go and indent all-- the comments by two since that does not work for latex style literate-- code. So the hacky solution we use here is that if we see any bird track-- style code then we'll indent all comments by two, otherwise by none.-- Of course this will not work for mixed latex/bird track .lhs files but-- nobody does that, it's silly and specifically recommended against in the-- H98 unlit spec.--classifyAndCheckForBirdTracks :: [String] -> (Bool, [Classified])
classifyAndCheckForBirdTracks =((Bool -> String -> (Bool, Classified))
 -> Bool -> [String] -> (Bool, [Classified]))
-> Bool
-> (Bool -> String -> (Bool, Classified))
-> [String]
-> (Bool, [Classified])
forall a b c. (a -> b -> c) -> b -> a -> c
flip(Bool -> String -> (Bool, Classified))
-> Bool -> [String] -> (Bool, [Classified])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumLBool
False((Bool -> String -> (Bool, Classified))
 -> [String] -> (Bool, [Classified]))
-> (Bool -> String -> (Bool, Classified))
-> [String]
-> (Bool, [Classified])
forall a b. (a -> b) -> a -> b
$\Bool
seenBirdTrack String
line ->letclassification :: Classified
classification =String -> Classified
classify String
line in(Bool
seenBirdTrack Bool -> Bool -> Bool
||Classified -> Bool
isBirdTrack Classified
classification ,Classified
classification )isBirdTrack :: Classified -> Bool
isBirdTrack (BirdTrack String
_)=Bool
TrueisBirdTrack Classified
_=Bool
FalsecheckErrors :: [Classified] -> Either [Classified] CabalException
checkErrors [Classified]
ls =case[String
e |Error String
e <-[Classified]
ls ]of[]->[Classified] -> Either [Classified] CabalException
forall a b. a -> Either a b
Left[Classified]
ls (String
message :[String]
_)->CabalException -> Either [Classified] CabalException
forall a b. b -> Either a b
Right(String -> CabalException
UnlitException (String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
showInt
n String -> String -> String
forall a. [a] -> [a] -> [a]
++String
": "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
message ))where(String
f ,Int
n )=String -> Int -> [Classified] -> (String, Int)
errorPos String
file Int
1[Classified]
ls errorPos :: String -> Int -> [Classified] -> (String, Int)
errorPos String
f Int
n []=(String
f ,Int
n )errorPos String
f Int
n (Error String
_:[Classified]
_)=(String
f ,Int
n )errorPos String
_Int
_(Line Int
n' String
f' :[Classified]
ls )=String -> Int -> [Classified] -> (String, Int)
errorPos String
f' Int
n' [Classified]
ls errorPos String
f Int
n (Classified
_:[Classified]
ls )=String -> Int -> [Classified] -> (String, Int)
errorPos String
f (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)[Classified]
ls -- Here we model a state machine, with each state represented by-- a local function. We only have four states (well, five,-- if you count the error state), but the rules-- to transition between then are not so simple.-- Would it be simpler to have more states?---- Each state represents the type of line that was last read-- i.e. are we in a comment section, or a latex-code section,-- or a bird-code section, etc?reclassify ::[Classified ]->[Classified ]reclassify :: [Classified] -> [Classified]
reclassify =[Classified] -> [Classified]
blank -- begin in blank statewherelatex :: [Classified] -> [Classified]
latex []=[]latex (Classified
EndCode :[Classified]
ls )=String -> Classified
Blank String
""Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
comment [Classified]
ls latex (Classified
BeginCode :[Classified]
_)=[String -> Classified
Error String
"\\begin{code} in code section"]latex (BirdTrack String
l :[Classified]
ls )=String -> Classified
Ordinary (Char
'>'Char -> String -> String
forall a. a -> [a] -> [a]
:String
l )Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
latex [Classified]
ls latex (Classified
l :[Classified]
ls )=Classified
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
latex [Classified]
ls blank :: [Classified] -> [Classified]
blank []=[]blank (Classified
EndCode :[Classified]
_)=[String -> Classified
Error String
"\\end{code} without \\begin{code}"]blank (Classified
BeginCode :[Classified]
ls )=String -> Classified
Blank String
""Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
latex [Classified]
ls blank (BirdTrack String
l :[Classified]
ls )=String -> Classified
BirdTrack String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
bird [Classified]
ls blank (Ordinary String
l :[Classified]
ls )=String -> Classified
Comment String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
comment [Classified]
ls blank (Classified
l :[Classified]
ls )=Classified
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
blank [Classified]
ls bird :: [Classified] -> [Classified]
bird []=[]bird (Classified
EndCode :[Classified]
_)=[String -> Classified
Error String
"\\end{code} without \\begin{code}"]bird (Classified
BeginCode :[Classified]
ls )=String -> Classified
Blank String
""Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
latex [Classified]
ls bird (Blank String
l :[Classified]
ls )=String -> Classified
Blank String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
blank [Classified]
ls bird (Ordinary String
_:[Classified]
_)=[String -> Classified
Error String
"program line before comment line"]bird (Classified
l :[Classified]
ls )=Classified
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
bird [Classified]
ls comment :: [Classified] -> [Classified]
comment []=[]comment (Classified
EndCode :[Classified]
_)=[String -> Classified
Error String
"\\end{code} without \\begin{code}"]comment (Classified
BeginCode :[Classified]
ls )=String -> Classified
Blank String
""Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
latex [Classified]
ls comment (CPP String
l :[Classified]
ls )=String -> Classified
CPP String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
comment [Classified]
ls comment (BirdTrack String
_:[Classified]
_)=[String -> Classified
Error String
"comment line before program line"]-- a blank line and another ordinary line following a comment-- will be treated as continuing the comment. Otherwise it's-- then end of the comment, with a blank line.comment (Blank String
l :ls :: [Classified]
ls @(Ordinary String
_:[Classified]
_))=String -> Classified
Comment String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
comment [Classified]
ls comment (Blank String
l :[Classified]
ls )=String -> Classified
Blank String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
blank [Classified]
ls comment (Line Int
n String
f :[Classified]
ls )=Int -> String -> Classified
Line Int
n String
f Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
comment [Classified]
ls comment (Ordinary String
l :[Classified]
ls )=String -> Classified
Comment String
l Classified -> [Classified] -> [Classified]
forall a. a -> [a] -> [a]
:[Classified] -> [Classified]
comment [Classified]
ls comment (Comment String
_:[Classified]
_)=[Classified]
forall a. a
internalError comment (Error String
_:[Classified]
_)=[Classified]
forall a. a
internalError -- Re-implementation of 'lines', for better efficiency (but decreased laziness).-- Also, importantly, accepts non-standard DOS and Mac line ending characters.inlines ::String->[String]inlines :: String -> [String]
inlines String
xs =String -> (String -> String) -> [String]
lines' String
xs String -> String
forall a. a -> a
idwherelines' :: String -> (String -> String) -> [String]
lines' []String -> String
acc =[String -> String
acc []]lines' (Char
'\^M':Char
'\n':String
s )String -> String
acc =String -> String
acc []String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> (String -> String) -> [String]
lines' String
s String -> String
forall a. a -> a
id-- DOSlines' (Char
'\^M':String
s )String -> String
acc =String -> String
acc []String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> (String -> String) -> [String]
lines' String
s String -> String
forall a. a -> a
id-- MacOSlines' (Char
'\n':String
s )String -> String
acc =String -> String
acc []String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> (String -> String) -> [String]
lines' String
s String -> String
forall a. a -> a
id-- Unixlines' (Char
c :String
s )String -> String
acc =String -> (String -> String) -> [String]
lines' String
s (String -> String
acc (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:))internalError ::a internalError :: forall a. a
internalError =String -> a
forall a. HasCallStack => String -> a
errorString
"unlit: internal error"