module DDC.Source.Tetra.Transform.Defix.FixTable
( FixTable (..)
, FixDef (..)
, InfixAssoc (..)
, lookupDefInfixOfSymbol
, lookupDefPrefixOfSymbol
, getInfixDefOfSymbol
, defaultFixTable)
where
import DDC.Source.Tetra.Transform.Defix.Error
import DDC.Source.Tetra.Prim
import DDC.Source.Tetra.Exp
import Data.List
import qualified DDC.Data.SourcePos as BP
data FixTable a n
= FixTable [FixDef a n]
data FixDef a n
= FixDefPrefix
{
fixDefSymbol :: String
, fixDefExp :: a -> Exp a n }
| FixDefInfix
{
fixDefSymbol :: String
, fixDefExp :: a -> Exp a n
, fixDefAssoc :: InfixAssoc
, fixDefPrec :: Int }
data InfixAssoc
= InfixLeft
| InfixRight
| InfixNone
deriving (Show, Eq)
lookupDefInfixOfSymbol :: FixTable a n -> String -> Maybe (FixDef a n)
lookupDefInfixOfSymbol (FixTable defs) str
= find (\def -> case def of
FixDefInfix{} -> fixDefSymbol def == str
_ -> False)
defs
lookupDefPrefixOfSymbol :: FixTable a n -> String -> Maybe (FixDef a n)
lookupDefPrefixOfSymbol (FixTable defs) str
= find (\def -> case def of
FixDefPrefix{} -> fixDefSymbol def == str
_ -> False)
defs
getInfixDefOfSymbol
:: a
-> FixTable a n
-> String
-> Either (Error a n) (FixDef a n)
getInfixDefOfSymbol a table str
= case lookupDefInfixOfSymbol table str of
Nothing -> Left (ErrorNoInfixDef a str)
Just def -> Right def
defaultFixTable :: FixTable BP.SourcePos Name
defaultFixTable
= FixTable
[ FixDefPrefix "-" (\sp -> XVar sp (UName (NameVar "neg")))
, FixDefInfix "*" (\sp -> XVar sp (UName (NameVar "mul"))) InfixLeft 7
, FixDefInfix "+" (\sp -> XVar sp (UName (NameVar "add"))) InfixLeft 6
, FixDefInfix "-" (\sp -> XVar sp (UName (NameVar "sub"))) InfixLeft 6
, FixDefInfix "==" (\sp -> XVar sp (UName (NameVar "eq" ))) InfixNone 5
, FixDefInfix "/=" (\sp -> XVar sp (UName (NameVar "neq"))) InfixNone 5
, FixDefInfix "<" (\sp -> XVar sp (UName (NameVar "lt" ))) InfixNone 5
, FixDefInfix "<=" (\sp -> XVar sp (UName (NameVar "le" ))) InfixNone 5
, FixDefInfix ">" (\sp -> XVar sp (UName (NameVar "gt" ))) InfixNone 5
, FixDefInfix ">=" (\sp -> XVar sp (UName (NameVar "ge" ))) InfixNone 5
, FixDefInfix "$" (\sp -> XVar sp (UName (NameVar "app"))) InfixRight 1 ]