-
Notifications
You must be signed in to change notification settings - Fork 5
/
Parse.hs
213 lines (159 loc) · 6.1 KB
/
Parse.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
{-# LANGUAGE RelaxedPolyRec, PatternGuards, ViewPatterns #-}
module Parse
( Doc (..)
, BBlock (..)
, Prompt
, mainParse
, getCommand
, printName
, parseQuickCheck
) where
import Text.Pandoc
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Syntax
{- Agda support (unfinished)
import qualified Agda.Syntax.Common as Agda
import qualified Agda.Syntax.Concrete as Agda
import qualified Agda.Syntax.Parser as Agda
-}
import Data.List.Split (splitOn)
import Data.List (tails, partition, groupBy)
import Data.Function (on)
import Data.Char (isAlpha, isSpace, toUpper, isUpper)
import Control.Monad (zipWithM)
--------------------------------- data structures
data Doc
= Doc
Meta{-title, author, date-}
Module{-module directives, module name, imports-}
[BBlock]
deriving (Show)
data BBlock
= Text Block{-pandoc block-}
| OneLineExercise
Prompt
Bool{-intentional error-}
String
| Exercise
[String]{-lines-}
[String]{-visible lines-}
[String]{-hidden lines-}
[Name]{-defined names-}
[String]{-test expressions-}
deriving (Show)
type Prompt = Char -- see the separate documentation
-----------------------------------
mainParse :: Bool -> FilePath -> IO Doc
mainParse agda s = do
c <- readFile s
case readMarkdown pState . unlines . concatMap preprocess . lines $ c of
Pandoc meta (CodeBlock ("",["sourceCode","literate","haskell"],[]) h: blocks) -> do
header <- liftError . parseModule' $ h
fmap (Doc meta header) $ collectTests agda $ map (interpreter . Text) blocks
Pandoc meta blocks -> do
header <- liftError . parseModule' $ "module Unknown where"
fmap (Doc meta header) $ collectTests agda $ map (interpreter . Text) blocks
where
parseModule' = parseModuleWithMode defaultParseMode
preprocess (c:'>':' ':l) | c `elem` commandList
= ["~~~~~ {." ++ [c] ++ "}", dropWhile (==' ') l, "~~~~~", ""]
preprocess ('|':l)
= []
preprocess l
= [l]
pState = defaultParserState
{ stateSmart = True
, stateStandalone = True
, stateLiterateHaskell = True
}
liftError :: (Monad m, Show a) => ParseResult a -> m a
liftError (ParseOk m) = return m
liftError x = fail $ "parseHeader: " ++ show x
interpreter :: BBlock -> BBlock
interpreter (Text (CodeBlock ("",[[x]],[]) e)) | x `elem` commandList
= OneLineExercise (toUpper x) (isUpper x) e
interpreter a = a
commandList, testCommandList :: String
commandList = "AaRr" ++ testCommandList
testCommandList = "EeFfH"
------------------------------
collectTests :: Bool -> [BBlock] -> IO [BBlock]
collectTests agda l = zipWithM f l $ tail $ tails l where
f (Text (CodeBlock ("",["sourceCode","literate","haskell"],[]) h)) l = do
let
isExercise = True -- not $ null $ concatMap fst exps
(visible, hidden, funnames) <- processLines agda isExercise h
let
exps = [snd $ getCommand e | (OneLineExercise _ _ e) <- takeWhile p l]
p (OneLineExercise x _ e) = x `elem` testCommandList && fst (getCommand e) == ""
p _ = False
return $ Exercise (lines h) visible hidden funnames exps
f x _ = return x
processLines :: Bool -> Bool -> String -> IO ([String], [String], [Name])
--processLines True = processAgdaLines
processLines _ = processHaskellLines
{- Agda support (unfinished)
processAgdaLines :: Bool -> String -> IO ([String], [String], [Name])
processAgdaLines isExercise l_ = do
let
l = parts l_
x <- fmap (zip l) $ mapM (Agda.parse Agda.moduleParser . ("module X where\n"++) . unlines) l
let
names = map toName $ concatMap (getFName . snd . snd) x
-- getFName [Agda.Module _ _ [Agda.TypedBindings _ (Agda.Arg _ _ [Agda.TBind _ a _])] declarations]
-- = map Agda.boundName a
getFName [Agda.Module _ _ _ [Agda.TypeSig _ n _]]
= [n]
getFName _ = []
-- isVisible [Agda.Module _ _ [Agda.TypedBindings _ (Agda.Arg _ _ [Agda.TBind _ a _])] declarations]
-- = True
isVisible [Agda.Module _ _ _ [Agda.TypeSig _ n _]] = True
isVisible _ = not isExercise
(visible, hidden) = partition (isVisible . snd . snd) x
toName n = Ident $ show n
return (concatMap fst visible, concatMap fst hidden, names)
-}
processHaskellLines :: Bool -> String -> IO ([String], [String], [Name])
processHaskellLines isExercise l_ = return (concatMap fst visible, concatMap fst hidden, names)
where
x = zip l $ map (parseDeclWithMode defaultParseMode . unlines) l
l = parts l_
names = concatMap (getFName . snd) x
getFName (ParseOk x) = case x of
TypeSig _ a _ -> a
PatBind _ (PVar a) _ _ _ -> [a]
FunBind (Match _ a _ _ _ _ :_) -> [a]
TypeDecl _ a _ _ -> [a]
DataDecl _ _ _ a _ x _ -> a: [n | QualConDecl _ _ _ y<-x, n <- getN y]
_ -> []
getFName _ = []
getN (ConDecl n _) = [n]
getN (InfixConDecl _ n _) = [n]
getN (RecDecl n l) = n: concatMap fst l
isVisible (ParseOk (TypeSig _ _ _)) = True
isVisible (ParseOk (InfixDecl _ _ _ _)) = True
isVisible _ = not isExercise
(visible, hidden) = partition (isVisible . snd) x
parts :: String -> [[String]]
parts = groupBy (const id `on` isIndented) . lines where
isIndented s | all isSpace s = True
isIndented (' ':_) = True
isIndented _ = False
------------------------------
getCommand :: String -> (String, String)
getCommand (':':'?': (dropSpace -> Just x))
= ("?", x)
getCommand (':': (span isAlpha -> (c@(_:_), dropSpace -> Just x)))
= (c, x)
getCommand s
= ("", s)
dropSpace :: String -> Maybe String
dropSpace (' ':y) = Just $ dropWhile (==' ') y
dropSpace "" = Just ""
dropSpace _ = Nothing
parseQuickCheck :: String -> ([String], String)
parseQuickCheck s = case splitOn ";;" s of
l -> (init l, last l)
printName :: Name -> String
printName (Ident x) = x
printName (Symbol x) = x