Sintyoku

Parser.hs

{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE OverloadedLists            #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE NamedFieldPuns             #-}

module Language.LeatherScript.Parser where

import           Control.Lens                   hiding (Level, parts)
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Identity
import           Control.Monad.State
import           Control.Monad.Trans.Either
import           Control.Monad.Trans.Loop
import           Data.Composition((.:))
import qualified Data.Maybe                     as Maybe
import qualified Data.List                      as List
import qualified Data.Text                      as Text
import qualified Data.Vector                    as Vector
import qualified Data.HashSet                   as HashSet
import qualified Data.HashMap.Strict            as HashMap
import qualified Language.LeatherScript.Types()

type Variable = Text.Text
type Keyword = Text.Text

data NotationPart
  = Variable Variable
  | Keyword Keyword
  deriving (Show)

type NotationParts = Vector.Vector NotationPart
type Replacement = SyntaxTree

data Associativity
  = NoAssoc
  | LeftAssoc
  | RightAssoc
  deriving (Show)

type Level = Int

data Pattern
  = Prefix Keyword NotationParts Variable
  | Postfix Variable NotationParts Keyword
  | Outfix Keyword NotationParts Keyword
  | Infix Variable NotationParts Variable
  | Alias Keyword
  deriving (Show)

data Notation
  = Notation
    { _pattern :: Pattern
    , _replacement :: Replacement
    , _associativity :: Associativity
    , _level :: Level
    }
  deriving (Show)

type Keywords = HashSet.HashSet Keyword
type Notations = HashMap.HashMap Keyword Notation

type NotationStackValue = (Notation, Vector.Vector SyntaxTree, Vector.Vector Keyword)
type NotationStack = Vector.Vector NotationStackValue

data SyntaxTree
  = Token Text.Text
  | Preference (Vector.Vector SyntaxTree)
  deriving (Eq)

instance Show SyntaxTree where
  show (Token txt) = Text.unpack txt
  show (Preference v) = "(" ++ (join $ List.intersperse " " $ Vector.toList $ Vector.map show v) ++ ")"

data ParseError
  = Unexpected Text.Text -- expecting
                Text.Text -- got
  deriving (Show, Eq)

type ParserStack = Vector.Vector SyntaxTree

data ParserState
  = ParserState
    { _keywords :: Keywords
    , _notations :: Notations
    , _notationStack :: NotationStack
    , _parserStack :: ParserStack
    , _tokens :: Vector.Vector Text.Text
    }

newtype ParserT m a
  = ParserT
    {
      unParserT :: EitherT ParseError (StateT ParserState m) a
    }
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadState ParserState
    , MonadIO
    )

type Parser = ParserT Identity

makeLenses ''Notation
makeLenses ''ParserState

runParserT :: Monad m => ParserT m a -> ParserState -> m (Either ParseError a)
runParserT = evalStateT . runEitherT . unParserT

runParser :: Parser a -> ParserState -> Either ParseError a
runParser = runIdentity .: (evalStateT . runEitherT . unParserT)

parseError :: Monad m => ParseError -> ParserT m a
parseError err = ParserT $ left err

countVariableInNotationPart :: NotationPart -> Int
countVariableInNotationPart (Variable _) = 1
countVariableInNotationPart (Keyword _) = 0

countVariableInNotationParts :: NotationParts -> Int
countVariableInNotationParts parts = Vector.sum $ Vector.map countVariableInNotationPart parts

countVariableInPattern :: Pattern -> Int
countVariableInPattern (Prefix _ parts _) = countVariableInNotationParts parts + 1
countVariableInPattern (Postfix _ parts _) = countVariableInNotationParts parts + 1
countVariableInPattern (Outfix _ parts _) = countVariableInNotationParts parts
countVariableInPattern (Infix _ parts _) = countVariableInNotationParts parts + 2
countVariableInPattern (Alias _) = 0

countVariableInReplacement :: Replacement -> Int
countVariableInReplacement (Token (Text.uncons -> Just ('$', _))) = 1
countVariableInReplacement (Token _) = 0
countVariableInReplacement (Preference v) = Vector.sum (Vector.map countVariableInReplacement v)

variablesInNotationPart :: NotationPart -> Vector.Vector Variable
variablesInNotationPart (Variable v) = Vector.singleton v
variablesInNotationPart (Keyword _) = Vector.empty

variablesInNotationParts :: NotationParts -> Vector.Vector Variable
variablesInNotationParts parts = Vector.concatMap variablesInNotationPart parts

variablesInPattern :: Pattern -> Vector.Vector Variable
variablesInPattern (Prefix _ parts v) = Vector.snoc (variablesInNotationParts parts) v
variablesInPattern (Postfix v parts _) = Vector.cons v (variablesInNotationParts parts)
variablesInPattern (Outfix _ parts _) = variablesInNotationParts parts
variablesInPattern (Infix v1 parts v2) = Vector.cons v1 (Vector.snoc (variablesInNotationParts parts) v2)

keywordsInNotationPart :: NotationPart -> Vector.Vector Keyword
keywordsInNotationPart (Variable _) = Vector.empty
keywordsInNotationPart (Keyword k) = Vector.singleton k

keywordsInNotationParts :: NotationParts -> Vector.Vector Keyword
keywordsInNotationParts parts = Vector.concatMap keywordsInNotationPart parts

keywordsInPattern :: Pattern -> Vector.Vector Keyword
keywordsInPattern (Prefix k parts _) = Vector.cons k (keywordsInNotationParts parts)
keywordsInPattern (Postfix _ parts k) = Vector.snoc (keywordsInNotationParts parts) k
keywordsInPattern (Outfix k1 parts k2) = Vector.cons k1 (Vector.snoc (keywordsInNotationParts parts) k2)
keywordsInPattern (Infix _ parts _) = keywordsInNotationParts parts

mkEnvironment :: Pattern -> Vector.Vector SyntaxTree -> HashMap.HashMap Variable SyntaxTree
mkEnvironment pattern arguments = do
  let variables = variablesInPattern pattern
  HashMap.fromList $ Vector.toList $ Vector.zip variables arguments

subst :: Replacement -> HashMap.HashMap Variable SyntaxTree -> SyntaxTree
subst (Token v@(Text.uncons -> Just ('$', _))) e = Maybe.fromJust $ HashMap.lookup v e
subst st@(Token _) _ = st
subst (Preference v) e = Preference (Vector.map (\st -> subst st e) v)

parse :: Monad m => Vector.Vector Text.Text -> ParserT m SyntaxTree
parse _tokens = do
  tokens .= _tokens
  let rec = do
        parse1
        ParserState{_tokens} <- get
        case _tokens of
          [] -> do
            ParserState{_parserStack, _notationStack} <- get
            Vector.forM_ _notationStack $ \_ -> reduceLeft 
            ParserState{_parserStack, _notationStack} <- get
            return $ Vector.head _parserStack
          _ -> rec
  rec

takeOperand :: Monad m => ParserT m ()
takeOperand = do
  operands <- use (notationStack . element 0 . _2)
  operand <- uses parserStack Vector.head
  let newOperands = Vector.snoc operands operand
  notationStack . element 0 . _2 .= newOperands
  parserStack %= Vector.tail

reduceLeft :: Monad m => ParserT m ()
reduceLeft = do
  takeOperand
  (notation, operands, unconsumedKeywords) <- uses notationStack Vector.head
  let e = mkEnvironment (notation ^. pattern) operands
  let st = subst (notation ^. replacement) e
  notationStack %= Vector.tail
  parserStack %= Vector.cons st

reduceGroup :: Monad m => Notation -> ParserT m ()
reduceGroup notation = do
  ParserState{_notationStack} <- get
  foreach (Vector.toList _notationStack) $ \(left, arguments, unconsumedKeywords) -> do
    case left ^. pattern of
      Outfix _ _ _ ->
        exit
      _ -> do
        if
          | (countVariableInPattern (left ^. pattern) - Vector.length arguments) == 1 -> do
            if
              | (left ^. level) < (notation ^. level) -> do
                exit
              | (left ^. level) > (notation ^. level) -> do
                lift reduceLeft
              | otherwise -> do
                case (left ^. associativity, left ^. associativity) of
                  (LeftAssoc, LeftAssoc) ->
                    lift reduceLeft
                  (RightAssoc, RightAssoc) ->
                    exit
                  _ ->
                    error "I'm sorry. several associativities are pending features."
          | otherwise -> do
            exit

parse1 :: Monad m => ParserT m ()
parse1 = do
  ParserState{_tokens, _keywords} <- get
  if
    | Vector.length _tokens == 0 -> do
      return ()
    | HashSet.member (Vector.head _tokens) _keywords -> do
      let kw = Vector.head _tokens
      ParserState{_notations} <- get
      case HashMap.lookup kw _notations of
        Just notation -> do
          case notation of
            Notation (Prefix _ _ _) _ _ _ -> do
              notationStack %= Vector.cons (notation, [], Vector.tail (keywordsInPattern (notation ^. pattern)))
              tokens %= Vector.tail
            Notation (Postfix _ [] _) _ _ _ -> do
              reduceGroup notation
              left <- uses parserStack Vector.head
              notationStack %= Vector.cons (notation, [left], Vector.tail (keywordsInPattern (notation ^. pattern)))
              parserStack %= Vector.tail
              tokens %= Vector.tail
              (notation, operands, unconsumedKeywords) <- uses notationStack Vector.head
              let e = mkEnvironment (notation ^. pattern) operands
              let st = subst (notation ^. replacement) e
              notationStack %= Vector.tail
              parserStack %= Vector.cons st
            Notation (Postfix _ _ _) _ _ _ -> do
              reduceGroup notation
              left <- uses parserStack Vector.head
              notationStack %= Vector.cons (notation, [left], Vector.tail (keywordsInPattern (notation ^. pattern)))
              parserStack %= Vector.tail
              tokens %= Vector.tail
            Notation (Outfix open _ close) _ _ _ -> do
              notationStack %= Vector.cons (notation, [], Vector.tail (keywordsInPattern (notation ^. pattern)))
              tokens %= Vector.tail

              -- for instance, "| x |"
              when (open == close) $ do
                notations %= HashMap.delete kw
            Notation (Infix _ _ _) _ _ _ -> do
              reduceGroup notation
              left <- uses parserStack Vector.head
              notationStack %= Vector.cons (notation, [left], Vector.tail (keywordsInPattern (notation ^. pattern)))
              parserStack %= Vector.tail
              tokens %= Vector.tail
        Nothing -> do
          ParserState{_notationStack} <- get
          foreach (Vector.toList _notationStack) $ \(notation, arguments, unconsumedKeywords) -> do
            case unconsumedKeywords of
              [] -> do
                lift reduceLeft
              (Vector.head -> expectingKeyword) -> do
                if kw == expectingKeyword
                  then do
                    lift $ notationStack . element 0 . _3 %= Vector.tail
                    exit
                  else do
                    lift $ parseError $ Unexpected expectingKeyword kw
          (notation, arguments, unconsumedKeywords) <- uses notationStack Vector.head
          if countVariableInPattern (notation ^. pattern) - Vector.length arguments == 1
            then
              reduceLeft
            else
              takeOperand
          case notation ^. pattern of
            Outfix open _ close
              | open == close -> do
                notations %= HashMap.insert open notation
              | otherwise -> do
                return ()
            _ -> do
              return ()
          tokens %= Vector.tail
    | otherwise -> do
      tk <- uses tokens Vector.head
      let st = Token tk
      parserStack %= Vector.cons st
      tokens %= Vector.tail

emptyParserState :: ParserState
emptyParserState
  = ParserState
    { _keywords = HashSet.empty
    , _notations = HashMap.empty
    , _notationStack = []
    , _parserStack = []
    , _tokens = []
    }

ParserSpec.hs

{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE OverloadedLists            #-}

import Test.Hspec

import           Control.Applicative
import           Control.Lens
import           Language.LeatherScript.Parser
import qualified Data.Text                      as Text
import qualified Data.Vector                    as Vector
import qualified Data.HashSet                   as HashSet
import qualified Data.HashMap.Strict            as HashMap
import qualified Text.Trifecta
import qualified Text.Trifecta.Delta

tokenize :: String -> Vector.Vector Text.Text
tokenize s = case Text.Trifecta.parseString tks (Text.Trifecta.Delta.Columns 0 0) s of
    Text.Trifecta.Success x -> x
    Text.Trifecta.Failure e -> error (show e)
  where
    tks = Vector.fromList <$> many (Text.Trifecta.spaces *> tk <* Text.Trifecta.spaces)
    tk = Text.pack <$> some (Text.Trifecta.noneOf " ")

sexp :: String -> SyntaxTree
sexp s = case Text.Trifecta.parseString parser (Text.Trifecta.Delta.Columns 0 0) s of
    Text.Trifecta.Success x -> x
    Text.Trifecta.Failure e -> error (show e)
  where
    parser = Text.Trifecta.spaces *> (pref <|> token) <* Text.Trifecta.spaces
    pref = do
      Text.Trifecta.char '('
      xs <- many parser
      Text.Trifecta.char ')'
      return $ Preference $ Vector.fromList xs

    token = Token . Text.pack <$> some (Text.Trifecta.noneOf "() ")

prefixNotations :: ParserState
prefixNotations
  = emptyParserState
    & keywords .~ HashSet.fromList ["~", "if", "then", "else"]
    & notations .~ HashMap.fromList [
                      ("~", Notation (Prefix "~" [] "$a") (sexp "(~ $a)") RightAssoc 35)
                    , ("if", Notation (Prefix "if" [Variable "$a", Keyword "then", Variable "$b", Keyword "else"] "$c") (sexp "(if-then-else $a $b $c)") RightAssoc 0)
                    ]

postfixNotations :: ParserState
postfixNotations
  = emptyParserState
    & keywords .~ HashSet.fromList ["!"]
    & notations .~ HashMap.fromList [
                      ("!", Notation (Postfix "$a" [] "!") (sexp "(! $a)") LeftAssoc 80)
                    ]

outfixNotations :: ParserState
outfixNotations
  = emptyParserState
    & keywords .~ HashSet.fromList ["(", ")", "|"]
    & notations .~ HashMap.fromList [
                    ("(", Notation (Outfix "(" [Variable "$a"] ")") (sexp "$a") NoAssoc 200)
                  , ("|", Notation (Outfix "|" [Variable "$a"] "|") (sexp "(abs $a)") NoAssoc 200)
                  ]

infixNotations :: ParserState
infixNotations
  = emptyParserState
    & keywords .~ HashSet.fromList ["+","-","*","/","=","?",":","and","or"]
    & notations .~ HashMap.fromList [
                        ("+", Notation (Infix "$a" [Keyword "+"] "$b") (sexp "(+ $a $b)") LeftAssoc 60)
                    ,   ("-", Notation (Infix "$a" [Keyword "-"] "$b") (sexp "(- $a $b)") LeftAssoc 60)
                    ,   ("*", Notation (Infix "$a" [Keyword "*"] "$b") (sexp "(* $a $b)") LeftAssoc 70)
                    ,   ("/", Notation (Infix "$a" [Keyword "/"] "$b") (sexp "(/ $a $b)") LeftAssoc 70)
                    ,   ("=", Notation (Infix "$a" [Keyword "="] "$b") (sexp "(= $a $b)") NoAssoc 40)
                    ,   ("?", Notation (Infix "$a" [Keyword "?", Variable "$b", Keyword ":"] "$c") (sexp "(?: $a $b $c)") RightAssoc 10)
                    ,   ("and", Notation (Infix "$a" [Keyword "and"]"$b") (sexp "(and $a $b)") RightAssoc 30)
                    ,   ("or", Notation (Infix "$a" [Keyword "or"] "$b") (sexp "(or $a $b)") RightAssoc 20)
                    ]

complexNotations :: ParserState
complexNotations
  = emptyParserState
    & keywords .~ HashSet.unions [
                      prefixNotations ^. keywords
                    , postfixNotations ^. keywords
                    , outfixNotations ^. keywords
                    , infixNotations ^. keywords
                    ]
    & notations .~ HashMap.unions [
                      prefixNotations ^. notations
                    , postfixNotations ^. notations
                    , outfixNotations ^. notations
                    , infixNotations ^. notations
                    ]

main :: IO ()
main = hspec $ do
  describe "prefix notations" $ do
    let parse' tokens = runParser (parse tokens) prefixNotations
    let assert x y = parse' (tokenize x) `shouldBe` Right (sexp y)
    let failure x y = parse' (tokenize x) `shouldBe` Left y

    it "~ P == (~ P)" $ do
      assert "~ P" "(~ P)"

    it "~ ~ P == (~ (~ P))" $ do
      assert "~ ~ P" "(~ (~ P))"

    it "~ ~ ~ P == (~ (~ (~ P)))" $ do
      assert "~ ~ ~ P" "(~ (~ (~ P)))"

    it "if a then b else c == (if-then-else a b c)" $ do
      assert "if a then b else c" "(if-then-else a b c)"

    it "if ~ a then ~ b else ~ c == (if-then-else (~ a) (~ b) (~ c))" $ do
      assert "if ~ a then ~ b else ~ c" "(if-then-else (~ a) (~ b) (~ c))"

    it "if if a then b else c then if d then e else f else if g then h else i == (if-then-else (if-then-else a b c) (if-then-else d e f) (if-then-else g h i))" $ do
      assert "if if a then b else c then if d then e else f else if g then h else i" "(if-then-else (if-then-else a b c) (if-then-else d e f) (if-then-else g h i))"

    it "if a else b then c -> parse error" $ do
      failure "if a else b then c" (Unexpected "then" "else")

  describe "postfix notations" $ do
    let parse' tokens = runParser (parse tokens) postfixNotations
    let assert x y = parse' (tokenize x) `shouldBe` Right (sexp y)

    it "a ! == (! a)" $ do
      assert "a !" "(! a)"

    it "a ! ! == (! (! a))" $ do
      assert "a ! !" "(!(! a))"

    it "a ! ! ! == (! (! (! a)))" $ do
      assert "a ! ! !" "(! (! (! a)))"

  describe "outfix notations" $ do
    let parse' tokens = runParser (parse tokens) outfixNotations
    let assert x y = parse' (tokenize x) `shouldBe` Right (sexp y)

    it "(a) == a" $ do
      assert "( a )" "a"
    it "((a)) == a" $ do
      assert "( ( a ) )" "a"
    it "(((a))) == a" $ do
      assert "( ( ( a ) ) )" "a"

    it "|a| == (abs a)" $ do
      assert "| a |" "(abs a)"

  describe "infix notations" $ do
    let parse' tokens = runParser (parse tokens) infixNotations
    let assert x y = parse' (tokenize x) `shouldBe` Right (sexp y)
    it "a == a" $ do
      assert "a" "a"
    it "a + b == (+ a b)" $ do
      assert "a + b" "(+ a b)"
    it "a + b + c == (+ (+ a b) c)" $ do
      assert "a + b + c" "(+ (+ a b) c)"
    it "(a + b * c + d) == (+ (+ a (* b c)) d)" $ do
      assert "a + b * c + d" "(+ (+ a (* b c)) d)"
    it "(a * b + c + d) == (+ (+ (* a b) c) d)" $ do
      assert "a * b + c + d" "(+ (+ (* a b) c) d)"
    it "(a + b + c * d) == (+ (+ a b) (* c d))" $ do
      assert "a + b + c * d" "(+ (+ a b) (* c d))"
    it "(a * b + c * d) == (+ (* a b) (* c d))" $ do
      assert "a * b + c * d" "(+ (* a b) (* c d))"
    it "(a + b * c * d) == (+ a (* (* b c) d))" $ do
      assert "a + b * c * d" "(+ a (* (* b c) d))"
    it "(a * b * c + d) == (+ (* (* a b) c) d)" $ do
      assert "a * b * c + d" "(+ (* (* a b) c) d)"
    it "(x and y) == (and x y)" $ do
      assert "x and y" "(and x y)"
    it "(x and y and z) == (and x (and y z))" $ do
      assert "x and y and z" "(and x (and y z))"
    it "(a = b and c = d) == (and (= a b) (= c d))" $ do
      assert "a = b and c = d" "(and (= a b) (= c d))"
    -- TODO: a = b = c
    it "(a or b and c or d) == (or a (or (and b c) d))" $ do
      assert "a or b and c or d" "(or a (or (and b c) d))"
    it "(a and b or c or d) == (or (and a b) (or c d))" $ do
      assert "a and b or c or d" "(or (and a b) (or c d))"
    it "(a or b or c and d) == (or a (or b (and c d)))" $ do
      assert "a or b or c and d" "(or a (or b (and c d)))"
    it "(a and b or c and d) == (or (and a b) (and c d))" $ do
      assert "a and b or c and d" "(or (and a b) (and c d))"
    it "(a or b and c and d) == (or a (and b (and c d)))" $ do
      assert "a or b and c and d" "(or a (and b (and c d)))"
    it "(a and b and c or d) == (or (and a (and b c)) d)" $ do
      assert "a and b and c or d" "(or (and a (and b c)) d)"
    it "(a ? b : c) == (?: a b c)" $ do
      assert "a ? b : c" "(?: a b c)"
    it "(a ? b : c ? d : e) == (?: a b (?: c d e))" $ do
      assert "a ? b : c" "(?: a b c)"
    it "(a and b ? c + d : e + f) == (?: (and a b) (+ c d) (+ e f))" $ do
      assert "a and b ? c + d : e + f" "(?: (and a b) (+ c d) (+ e f))"

  describe "complex notations" $ do
    let parse' tokens = runParser (parse tokens) complexNotations
    let assert x y = parse' (tokenize x) `shouldBe` Right (sexp y)
    it "(a + b) == (+ a b)" $ do
      assert "( a + b )" "(+ a b)"
    it "a * (b + c) == (* a (+ b c))" $ do
      assert "a * ( b + c )" "(* a (+ b c))"
    it "~ a = b == (~ (= a b))" $ do
      assert "~ a = b" "(~ (= a b))"
    it "if a and b then c + d else e + f == (if-then-else (and a b) (+ c d) (+ e f))" $ do
      assert "if a and b then c + d else e + f" "(if-then-else (and a b) (+ c d) (+ e f))"
    it "~ a ! + ~ b ! == (~ (+ (! a) (~ (! b))))" $ do
      assert "~ a ! + ~ b !" "(~ (+ (! a) (~ (! b))))"

Types.hs

{-# LANGUAGE TypeFamilies #-}

module Language.LeatherScript.Types where

import qualified GHC.Exts
import qualified Data.Vector as Vector

instance GHC.Exts.IsList (Vector.Vector a) where
  type Item (Vector.Vector a) = a
  fromList  = Vector.fromList
  toList    = Vector.toList
  fromListN = Vector.fromListN