Parse.y

{
module Language.Cap.Interpret.Parse 
       (Program,RewriteRule(..),Term(..)
       ,parseProgram,parseTerm
       ,functionName,showRule) where

import Language.Cap.Interpret.Pretty

import Data.Char
}

%name parse Program
%name parseT Exp
%tokentype { Token }
%error { parseError }

%token
    variable    { TokenVariable $$ }
    constructor { TokenConstructor $$ }
    number      { TokenNumber $$ }
    'eof'       { TokenEOF }
    '\n'        { TokenEOR }
    '='         { TokenEq }
    '('         { TokenOB }
    ')'         { TokenCB }

%%

Program        : 'eof'                  { [] }
               | '\n' Program           { $2 }
               | Rule Program           { $1 : $2 }

Rule           : Function '=' Term      { Rule $1 $3 }

Function       : Function Pattern       { TApplication $1 $2 }
               | variable               { TAtom $1 }

Pattern        : '(' Pattern ')'        { $2 }
               | SConstruction          { $1 }
               | variable               { TVariable $1 }
               | number                 { TAtom $1 }

Construction   : '(' Construction ')'   { $2 }
               | Construction Pattern   { TApplication $1 $2 }
               | constructor            { TAtom $1 }

SConstruction  : '(' Construction ')'   { $2 }
               | constructor            { TAtom $1 }

TConstruction  : '(' TConstruction ')'  { $2 }
               | TConstruction STerm    { TApplication $1 $2 }
               | constructor            { TAtom $1 }

STConstruction : '(' TConstruction ')'  { $2 }
               | constructor            { TAtom $1 }

Term           : '(' Term ')'           { $2 }
               | Term STerm             { TApplication $1 $2 }
               | TConstruction          { $1 }
               | variable               { TAtom $1 }
               | number                 { TAtom $1 }

STerm          : '(' Term ')'           { $2 }
               | STConstruction         { $1 }
               | variable               { TAtom $1 }
               | number                 { TAtom $1 }

Exp            : Term 'eof'             { $1 }

{

-- | Terms are atoms, applications or variables.  When used on the LHS of a
--   rule, the function symbol must be an atom, and all arguments must be atoms
--   variables or applications of constructors.
data Term = TAtom String
          | TVariable String
          | TApplication Term Term
          deriving (Show,Read)

-- | A rewrite rule is made up of a pattern to match against, and a right hand
--   side to rewrite to.
data RewriteRule = Rule Term Term
                   deriving (Show,Read)

-- | Programs are simply lots of rewrite rules.
type Program = [RewriteRule]

parseError :: [Token] -> a
parseError x = error ("Out of cheese error, redo from start. " ++ show x)

data Token = TokenVariable String
           | TokenConstructor String
           | TokenNumber String
           | TokenEOR
           | TokenEOF
           | TokenEq
           | TokenOB
           | TokenCB
             deriving Show

lexer :: String -> [Token]
lexer []                   = [TokenEOF]
lexer ('\r':cs)            = TokenEOR : lexer cs
lexer ('\n':cs)            = TokenEOR : lexer cs
lexer (c:cs)
  | isSpace c              = lexer cs
  | isAlpha c && isUpper c = lexText TokenConstructor (c:cs)
  | isAlpha c && isLower c = lexText TokenVariable (c:cs)
  | isDigit c              = lexNum (c:cs)
lexer ('=':cs) = TokenEq : lexer cs
lexer ('(':cs) = TokenOB : lexer cs
lexer (')':cs) = TokenCB : lexer cs

lexNum cs = TokenNumber num : lexer rest
            where (num,rest) = span isDigit cs

lexText cons cs = cons text : lexer rest
                  where
                    (text,rest) = span isAlpha cs

-- | Takes a string representation of a pragram and parses into a list of rules
parseProgram :: String -> Program
parseProgram = sortVariables . parse . lexer

-- | Takes a string representation of a term and parses it
parseTerm :: String -> Term
parseTerm = parseT . lexer

sortVariables :: Program -> Program
sortVariables =
  map sortRuleVariables
  where
    sortRuleVariables :: RewriteRule -> RewriteRule
    sortRuleVariables (Rule p t) = Rule p (makeVariables t $ collectBindings p)
    
    collectBindings (TAtom _) = []
    collectBindings (TApplication i j) = collectBindings i ++ collectBindings j
    collectBindings (TVariable n) = [n]
    
    makeVariables t@(TAtom x) bs
      | x `elem` bs = TVariable x
      | otherwise   = TAtom x
    makeVariables (TApplication i j) bs =
      TApplication (makeVariables i bs) (makeVariables j bs)
    makeVariables x bs = x

-- | Returns the name of the function defined in a given rewrite rule
functionName :: RewriteRule -> String
functionName (Rule t _) =
  tHead t
  where
    tHead :: Term -> String
    tHead (TAtom x) = x
    tHead (TVariable x) = x
    tHead (TApplication f _) = tHead f

-- | Pretty prints a given rewrite rule
showRule :: RewriteRule -> String
showRule (Rule p e) =
  pretty (toPrettyTerm p) ++ " = " ++ pretty (toPrettyTerm e) ++ "\n"
  where
    toPrettyTerm (TAtom x) = PAtom x
    toPrettyTerm (TVariable x) = PAtom x
    toPrettyTerm (TApplication f a) =
      PApplication (toPrettyTerm f) (toPrettyTerm a)
}