2014-01-04 09:54:46 +00:00
|
|
|
{-# OPTIONS_GHC -W #-}
|
2013-07-16 19:38:20 +00:00
|
|
|
module Parse.Parse (program, dependencies) where
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-06-10 04:21:16 +00:00
|
|
|
import Control.Applicative ((<$>), (<*>))
|
2014-01-04 09:54:46 +00:00
|
|
|
import qualified Data.List as List
|
2013-08-29 09:53:20 +00:00
|
|
|
import qualified Data.Map as Map
|
2012-06-10 04:21:16 +00:00
|
|
|
import Text.Parsec hiding (newline,spaces)
|
2013-07-16 12:39:26 +00:00
|
|
|
import qualified Text.PrettyPrint as P
|
2012-06-10 04:21:16 +00:00
|
|
|
|
2013-12-24 07:26:03 +00:00
|
|
|
import qualified SourceSyntax.Declaration as D
|
2014-01-03 07:42:54 +00:00
|
|
|
import qualified SourceSyntax.Module as M
|
2013-06-14 03:25:00 +00:00
|
|
|
import Parse.Helpers
|
2013-09-15 21:34:56 +00:00
|
|
|
import Parse.Declaration (infixDecl)
|
2013-06-14 03:25:00 +00:00
|
|
|
import Parse.Module
|
2013-07-07 20:11:16 +00:00
|
|
|
import qualified Parse.Declaration as Decl
|
2014-01-03 07:42:54 +00:00
|
|
|
import Transform.Declaration (combineAnnotations)
|
2012-08-01 23:37:37 +00:00
|
|
|
|
2012-06-12 06:28:45 +00:00
|
|
|
freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
|
|
|
|
freshLine
|
2013-07-07 20:11:16 +00:00
|
|
|
Decl.declaration <?> "another datatype or variable definition"
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2013-07-07 20:11:16 +00:00
|
|
|
decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
|
|
|
|
(d:) <$> many freshDef
|
2012-06-10 04:21:16 +00:00
|
|
|
|
2014-01-03 07:42:54 +00:00
|
|
|
program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)
|
|
|
|
program table src =
|
|
|
|
do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src
|
|
|
|
decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)
|
|
|
|
return $ M.Module names exs ims decls
|
|
|
|
|
|
|
|
programParser :: IParser (M.Module D.ParseDeclaration)
|
|
|
|
programParser =
|
|
|
|
do optional freshLine
|
|
|
|
(names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
|
|
|
|
is <- (do try (lookAhead $ reserved "import")
|
|
|
|
imports `followedBy` freshLine) <|> return []
|
|
|
|
declarations <- decls
|
|
|
|
optional freshLine ; optional spaces ; eof
|
|
|
|
return $ M.Module names exports is declarations
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2013-07-16 19:38:20 +00:00
|
|
|
dependencies :: String -> Either [P.Doc] (String, [String])
|
|
|
|
dependencies =
|
2014-01-04 09:54:46 +00:00
|
|
|
let getName = List.intercalate "." . fst in
|
2013-07-16 19:38:20 +00:00
|
|
|
setupParser $ do
|
|
|
|
optional freshLine
|
|
|
|
(,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
|
|
|
|
<*> option [] (map fst <$> imports `followedBy` freshLine)
|
2013-02-27 07:33:47 +00:00
|
|
|
|
2013-08-29 09:53:20 +00:00
|
|
|
setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
|
|
|
|
setupParserWithTable table p source =
|
|
|
|
do localTable <- setupParser parseFixities source
|
|
|
|
case Map.intersection table localTable of
|
|
|
|
overlap | not (Map.null overlap) -> Left [ msg overlap ]
|
|
|
|
| otherwise ->
|
|
|
|
flip setupParser source $ do
|
|
|
|
putState (Map.union table localTable)
|
|
|
|
p
|
|
|
|
where
|
|
|
|
msg overlap =
|
|
|
|
P.vcat [ P.text "Parse error:"
|
|
|
|
, P.text $ "Overlapping definitions for infix operators: " ++
|
2014-01-04 09:54:46 +00:00
|
|
|
List.intercalate " " (Map.keys overlap)
|
2013-08-29 09:53:20 +00:00
|
|
|
]
|
|
|
|
|
2013-10-17 17:40:25 +00:00
|
|
|
parseFixities = do
|
|
|
|
decls <- onFreshLines (:) [] infixDecl
|
2013-12-24 07:26:03 +00:00
|
|
|
return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
|
2013-08-29 09:53:20 +00:00
|
|
|
|
2013-07-16 12:39:26 +00:00
|
|
|
setupParser :: IParser a -> String -> Either [P.Doc] a
|
2013-02-27 07:33:47 +00:00
|
|
|
setupParser p source =
|
2013-09-15 20:42:19 +00:00
|
|
|
case iParse p source of
|
2012-06-11 13:11:15 +00:00
|
|
|
Right result -> Right result
|
2013-07-22 12:40:00 +00:00
|
|
|
Left err -> Left [ P.text $ "Parse error at " ++ show err ]
|