casui-0.3: Casui/Parse.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Casui.Parse where

import Casui.Name
import Casui.Utils
import Casui.Value
import Casui.Module

import Data.Ratio
import Data.List
import Control.Monad
import Control.Monad.Error
import Control.Applicative hiding ((<|>), many)
import Control.Arrow
import Text.ParserCombinators.Parsec


nonSymbolChars :: [Char]
nonSymbolChars = " \r\n\t()\"#',`"

parseValue :: Parser ParsedValue
parseValue = pSpacesOrComment >> (
      pQQU
  <|> pList
  <|> pString
  <|> pNumber
  <|> pSymbol
  ) <* pSpacesOrComment

pSpacesOrComment :: Parser ()
pSpacesOrComment = spaces >> ((try $ char ';' >> skipMany (noneOf "\n")) <|> return ())

pQQU :: Parser ParsedValue
pQQU = do c <- oneOf "'`,"
          let n = case c of '\'' -> "quote"; ',' -> "unquote"; '`' -> "quasiquote"; _ -> unreachable
          spaces
          v <- parseValue
          ParsedValue <$> getPosition <*> return (VStruct (builtin $ "script:" ++ n) [v])

pList :: Parser ParsedValue
pList = ParsedValue <$> getPosition <*> (VList <$> (pParens $ many (parseValue <* spaces)))

pParens :: Parser a -> Parser a
pParens p = char '(' >> p <* char ')'

pString :: Parser ParsedValue
pString = ParsedValue <$> getPosition <*> fmap VString (
           char '"'
           >> (many $ pStringEscape <|> noneOf ['"'])
           <* char '"' )

pStringEscape :: Parser Char
pStringEscape = char '\\' >> do
                   c <- anyChar
                   case lookup c [('n','\n'),('\\','\\'),('\r','\r'),('\t','\t')] of
                     Just v -> return v
                     _ -> unexpected "unvalid use of backslash in string"

pNumber :: Parser ParsedValue
pNumber = lookAhead (digit <|> char '.') >> do
  (i :: Integer) <- maybe 0 read <$> optionMaybe (many1 digit)
  f <- maybe 0 fpart <$> optionMaybe (char '.' >> many1 digit)
  ParsedValue <$> getPosition <*> (return . VExact . toRational $ toRational i + f)
  where fpart = liftM2 (%) read $ (10^) . length
             
pSymbol :: Parser ParsedValue
pSymbol = ParsedValue <$> getPosition <*> (VName <$> pName)

pName :: Parser Name
pName = mkName <$> many1 (noneOf nonSymbolChars)


instance Show ParsedValue where
  show (ParsedValue _ v) = show v

uvModule :: FileId -> Name -> ParsedValue ->
            Either (TagError SourcePos) (Module ParsedName ParsedValue)
uvModule extid (Name parent)
  (val -> VList ((val -> VName (Name ["module"])) : (val -> VName (Name [nam])) : content)) = 
      let ([imps, defs], props) = groupVL [mkName "import", mkName "define"] $ content in do
        imports <- fmap (if null parent then id else (ParsedName Nothing (Name parent):)) .
                   fmap concat . mapM listImports $ map snd imps
        (defines, dprops) <- second concat . unzip <$> mapM (uncurry listDefines) defs
        properties <- map mkProp . (dprops ++) <$> mapM getProp props
        return $ Module (FullName extid $ parent ++ [nam])
          imports defines properties
        where
          listImports :: [ParsedValue] -> Either (TagError SourcePos) [ParsedName]
          listImports syms = mapM getName syms
          listDefines _def (sym:pprops) = do
            n <- getName sym
            s <- case n of ParsedName _ (Name [s]) -> return s
                           _otherwise -> Left $ err "compound name in define" $ pvSourcePos sym
            (mv, pprops') <- extractValue pprops
            ps <- mapM getPProp pprops'
            return ((s, mv), map (\(a,b) -> (a, n, b)) ps) 
          listDefines def _ = Left $ err "empty define" $ pvSourcePos def
          extractValue ps = case partition notList ps of
            ([a], l) -> return (Just a, l)
            ([], l) -> return (Nothing, l)
            ((_:v:_), _) -> Left $ err "too many values in define" $ pvSourcePos v
          notList (val -> VList _) = True
          notList _ = False
          getPProp :: ParsedValue -> Either (TagError SourcePos) (ParsedName, [ParsedValue])
          getPProp (val -> VList (prop:arg)) = liftM2 (,) (getName prop) (return arg)
          getPProp v = Left $ err "expecting a partial property" $ pvSourcePos v
          getProp :: ParsedValue -> Either (TagError SourcePos) (ParsedName, ParsedName, [ParsedValue])
          getProp (val -> VList (prop:name:arg)) = liftM3 (,,) (getName prop) (getName name) (return arg)
          getProp v = Left $ err "expecting a property" $ pvSourcePos v
          getName :: ParsedValue -> Either (TagError SourcePos) ParsedName
          getName v@(val -> VName n) = return $ ParsedName (Just $ pvSourcePos v) (n)
          getName v = Left $ err "expecting a symbol" $ pvSourcePos v
          mkProp :: (ParsedName, ParsedName, [ParsedValue]) ->
                    (ParsedName, Property ParsedName ParsedValue)
          mkProp (prop,obj,arg) = (obj, E prop arg)

uvModule _ _ (ParsedValue sp _) = Left $ err "expecting a module declaration" sp

groupVL :: Val v => [Name] -> [v] -> ([[(v, [v])]], [v])
groupVL [] vl = ([], vl)
groupVL (name:names) vl = first (match:) $ groupVL names others
  where (match, others) = extractVL name vl

extractVL :: Val v => Name -> [v] -> ([(v, [v])], [v])
extractVL _ [] = ([],[])
extractVL name (v:vs) = put $ extractVL name vs
  where put = case val v of VList ((val -> VName head):tail)
                                | head == name -> first ((v, tail):)
                            _otherwise -> second (v:)


type ParsedModule = Module ParsedName ParsedValue

data ParsedName = ParsedName (Maybe SourcePos) Name

instance HasName ParsedName where
  nameOf (ParsedName _ name) = name

data ParsedValue = ParsedValue { 
  pvSourcePos :: SourcePos,
  pvValue :: Value ParsedValue
  }

instance Val ParsedValue where
  val (ParsedValue _ v) = v