Parser.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Parser (Funcons.Parser.parse, Funcons.Parser.parser, pFuncons, pValues) where

import Text.ParserCombinators.Parsec

import Control.Applicative hiding ((<|>))
import Data.Char (isDigit)
import Data.Text (pack)
import Numeric

import Funcons.Lexer
import Funcons.Types

data Suffix = SuffixOp SeqSortOp
            | SuffixSort Funcons
            | SuffixBar Funcons
            | NoSuffix

pFuncons = applySuffix <$> pFuncons0 <*> mSuffix
    where   mSuffix :: Parser Suffix
            mSuffix =   SuffixOp <$> pOp
                    <|> SuffixSort <$ doubleArrow <*> pFuncons
                    <|> try (SuffixBar <$ bar <*> pFuncons) -- necessary for builtin maps
                    <|> return NoSuffix
            applySuffix f NoSuffix = f
            applySuffix f (SuffixOp op) = FSortSeq f op
            applySuffix f (SuffixSort f2) = FSortComputesFrom f f2
            applySuffix f (SuffixBar f2) = FSortUnion f f2

-- introduced to bottom-out left-recursion
pFuncons0 :: Parser Funcons
pFuncons0 = 
        FList           <$> brackets    (commaSep pFuncons)
    <|> try (FMap       <$> braces      (commaSep1 pKeyValue))
    <|> FSet            <$> braces      (commaSep pFuncons)
    <|> FTuple          <$> parens      (commaSep pFuncons)
    <|> FSortComputes   <$ doubleArrow <*> pFuncons
    <|> maybe_apply . pack  <$> identifier <*> optionMaybe pFuncons
    <|> FValue          <$> pValues
 where  pKeyValue :: Parser Funcons
        pKeyValue = (\x y -> FTuple [x,y]) <$> pFuncons <* barredArrow <*> pFuncons
       
        maybe_apply :: Name -> Maybe Funcons -> Funcons
        maybe_apply nm mf = case mf of 
                            Nothing     -> FName nm
                            Just arg    -> FApp nm arg


pOp :: Parser SeqSortOp
pOp =       StarOp <$ reserved "*"
        <|> PlusOp <$ reserved "+"
        <|> QuestionMarkOp <$ reserved "?"

pValues :: Parser Values 
pValues =
        Char <$ char '\'' <*> anyChar <* char '\'' 
    <|> String <$> stringLiteral 
    <|> EmptyTuple <$ reserved "void" 
    <|> List [] <$ reserved "nil"
    <|> String "\n" <$ reserved "newline" 
    <|> (\(FValue v) -> v) . int_ . (0-) . readInt <$ char '-' <*> (many1 digit) 
    <|> (\(FValue v) -> v) . nat_ . readInt <$> (many1 digit) 
    <|> Atom <$ reserved "atom" <*> parens stringLiteral
    <|> mk_rationals . readRational
            <$> ((\m l -> m ++ "." ++ l) <$> many1 (satisfy isDigit) <* period <*>
                                             many1 (satisfy isDigit))
  where readInt :: String -> Int
        readInt = read 

{-
ComputationTypes and Types should really be parsed as arbitrary terms,
    then evaluated to ComputationType/Type.
However, computation types can currently not be parsed because of left-recursion (see above).

pComputationType :: Parser ComputationTypes
pComputationType =  Type <$> pTypes
                <|> ComputesType <$ reserved "=>" <*> pTypes 
                <|> ComputesFromType <$> pTypes <* reserved "=>" <*> pTypes 

pTypes :: Parser Types
pTypes =
        Atoms <$ reserved "atoms"
    <|> AsciiCharacters <$ reserved "ascii-characters"
    <|> reserved "bounded-integers" *> 
            parens (BoundedIntegers <$> natural <* comma <*> natural)
    <|> ComputationTypes <$ reserved "computation-types"
    <|> EmptyType <$ reserved "empty-type"
    <|> UnicodeCharacters <$ reserved "unicode-characters"
    <|> Integers <$ reserved "integers"
    <|> Strings <$ reserved "strings"
    <|> Values <$ reserved "values" 
    <|> reserved "maps" *> parens (Maps <$> pTypes <* comma <*> pTypes)
    <|> Types <$ reserved "types"
    <|> ADTs <$ reserved "algebraic-datatypes"
--    <|> ADT      
    <|> reserved "bits" *> parens (Bits . fromInteger <$> natural)
    <|> IEEEFloats <$ reserved "ieee-floats" <*> parens pIEEEFormat
    <|> Lists <$ reserved "lists" <*> parens pTypes
    <|> Multisets <$ reserved "multisets" <*> parens pTypes
    <|> Naturals <$ reserved "naturals"
    <|> Rationals <$ reserved "rationals"
    <|> Thunks <$ reserved "thunks" <*> parens pComputationType
    <|> Sets <$ reserved "sets" <*> parens pTypes
    <|> Vectors <$ reserved "vectors" <*> parens pTypes
--    <|> Tuples <$ reserved "tuples" <*> parens (commaSep pTypes)
--    <|> parens (Union <$> pTypes <* reserved "|" <*> pTypes)
-}

pIEEEFormat :: Parser IEEEFormats
pIEEEFormat =   Binary32 <$ reserved "binary32"
            <|> Binary64 <$ reserved "binary64"

readRational :: String -> Rational
readRational = fst . head . readFloat

--------
parse :: FilePath -> String -> Funcons
parse = parser (whiteSpace *> pFuncons <* whiteSpace)

parser :: Parser a -> FilePath -> String -> a 
parser p fp str = case Text.ParserCombinators.Parsec.parse p fp str of
                    Left err -> error (show err)
                    Right a  -> a

reader :: Parser a -> FilePath -> String -> [(a, String)]
reader p fp str = [(parser p fp str, "")]

instance Read Funcons where
    readsPrec d str = reader pFuncons "" str

instance Read Values where
    readsPrec d str = reader pValues "" str