{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Language.Del.Reader
( Language.Del.Reader.read
, Form (DefForm, ImportForm)
) where
import qualified Data.ByteString.Char8 as BS
import qualified Data.Functor.Identity as Id
import qualified Data.Text as T
import Language.Del.AST
import Language.Del.CompileDefs
import Language.Del.TypeTable
import Network.HTTP.Req
import Text.Parsec
import qualified Text.Parsec.Text as PT
import qualified Text.Parsec.Token as Token
data Form
= DefForm T.Text Type [(T.Text, Type)] Expr
| ImportForm (Either Name SourceUrl) T.Text
instance Show Form where
show (DefForm n ret args body) = concat [
"(", T.unpack n, ":", (show ret), " ",
unwords $ map (\(a, t) -> T.unpack a ++ ":" ++ show t) args,
") -> ", show body]
show (ImportForm (Left n) alias) = concat [
"(#import ", T.unpack n, " -> ", T.unpack alias, ")"]
show (ImportForm (Right url) alias) = concat [
"(#import ", show url, " -> ", T.unpack alias, ")"]
lang :: Token.GenLanguageDef T.Text () Id.Identity
lang = Token.LanguageDef { Token.commentLine = ""
, Token.commentStart = "(*"
, Token.commentEnd = "*)"
, Token.nestedComments = False
, Token.identStart = letter
, Token.identLetter = alphaNum <|> oneOf "-"
, Token.opStart = oneOf "+-*/%^>=<$"
, Token.opLetter = oneOf "=" -- the only two-char ops are <= and >=
, Token.reservedNames = ["define"]
, Token.reservedOpNames = []
, Token.caseSensitive = True
}
lexer :: Token.GenTokenParser T.Text () Id.Identity
lexer = Token.makeTokenParser lang
parens = Token.parens lexer
name = Token.identifier lexer >>= return . T.pack
ws = Token.whiteSpace lexer
reserved = Token.reserved lexer
lexeme = Token.lexeme lexer
op = Token.operator lexer >>= return . T.pack
typedname :: PT.Parser (T.Text, Type)
typedname = do
n <- name
_ <- char ':'
t <- name
return (n, NamedType t)
sign :: PT.Parser (DelNum -> DelNum)
sign = lexeme $ (char '-' >> return negate) <|> (char '+' >> return id) <|> return id
number :: PT.Parser Expr
number = do
s <- sign
nof <- Token.naturalOrFloat lexer
return . Number . s $ case nof of
Left int -> DelInt int
Right double -> DelFloat double
apply :: PT.Parser Expr
apply = parens $ do
hd <- expr
rest <- many expr
return $ Apply hd rest
ident :: PT.Parser Expr
ident = do
n <- name
x <- optionMaybe (char '.' >> name)
case x of
Nothing -> return (Id n)
Just v -> return (ScopedId n v)
exprNoSub :: PT.Parser Expr
exprNoSub = ident
<|> (Id <$> op)
<|> apply
<|> number
<?> "expression"
expr :: PT.Parser Expr
expr = do
e <- exprNoSub
option e (char '_' >> name >>= return . (Subscript e))
-- Parses a definition without the enclosing braces
def :: PT.Parser Form
def = do
_ <- reserved "define"
(n, ret) <- typedname
args <- parens $ many typedname
body <- expr
return $ DefForm n ret args body
urlchars :: String
urlchars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" ++
"-._~:/?#[]@!$&'()*+,;=`."
parseurl :: String -> Maybe SourceUrl
parseurl s =
if take 5 s == "https"
then case parseUrlHttps (BS.pack s) of
Just (url, _) -> Just $ HttpsSource url
Nothing -> Nothing
else case parseUrlHttp (BS.pack s) of
Just (url, _) -> Just $ HttpSource url
Nothing -> Nothing
-- Parses an import without the enclosing braces
imports :: PT.Parser Form
imports = do
_ <- reserved "import"
src <- lexeme $ many1 (oneOf urlchars)
alias <- name
case parseurl src of
Just url -> return $ ImportForm (Right url) alias
Nothing -> case Text.Parsec.parse name "-" (T.pack src) of
Left _ -> fail ("import " ++ src ++
" is neither a URL nor a name")
Right _ -> return $ ImportForm (Left $ T.pack src) alias
form :: PT.Parser Form
form = parens (def <|> imports)
top :: PT.Parser [Form]
top = ws *> many1 form
read :: T.Text -> Artifact [Form]
read t = case Text.Parsec.parse top "source" t of
Left err -> Failure (ReadError err)
Right exprs -> return exprs