module DDC.Core.Eval.Name
( Name (..)
, PrimCon (..)
, PrimOp (..)
, Loc (..)
, Rgn (..)
, Cap (..)
, readName
, lexString)
where
import DDC.Base.Pretty
import DDC.Base.Lexer
import DDC.Core.Parser.Lexer
import DDC.Core.Parser.Tokens
import Data.Char
import Data.Maybe
data Name
= NameVar String
| NameCon String
| NameInt Integer
| NamePrimCon PrimCon
| NamePrimOp PrimOp
| NameLoc Loc
| NameRgn Rgn
| NameCap Cap
deriving (Show, Eq, Ord)
instance Pretty Name where
ppr nn
= case nn of
NameVar v -> text v
NameCon c -> text c
NameInt i -> text (show i)
NamePrimCon c -> ppr c
NamePrimOp op -> ppr op
NameLoc l -> ppr l
NameRgn r -> ppr r
NameCap p -> ppr p
data Loc
= Loc Int
deriving (Eq, Ord, Show)
instance Pretty Loc where
ppr (Loc l)
= text "L" <> text (show l) <> text "#"
data Rgn
= Rgn Int
deriving (Eq, Ord, Show)
instance Pretty Rgn where
ppr (Rgn r)
= text "R" <> text (show r) <> text "#"
data Cap
= CapGlobal
| CapConst
| CapMutable
| CapLazy
| CapManifest
deriving (Eq, Ord, Show)
instance Pretty Cap where
ppr cp
= case cp of
CapGlobal -> text "Global#"
CapConst -> text "Const#"
CapMutable -> text "Mutable#"
CapLazy -> text "Lazy#"
CapManifest -> text "Manifest#"
data PrimCon
= PrimTyConUnit
| PrimTyConInt
| PrimTyConPair
| PrimTyConList
| PrimDaConUnit
| PrimDaConPr
| PrimDaConNil
| PrimDaConCons
deriving (Show, Eq, Ord)
instance Pretty PrimCon where
ppr con
= case con of
PrimTyConUnit -> text "Unit"
PrimTyConInt -> text "Int"
PrimTyConPair -> text "Pair"
PrimTyConList -> text "List"
PrimDaConUnit -> text "()"
PrimDaConPr -> text "Pr"
PrimDaConNil -> text "Nil"
PrimDaConCons -> text "Cons"
data PrimOp
= PrimOpNegInt
| PrimOpAddInt
| PrimOpSubInt
| PrimOpMulInt
| PrimOpDivInt
| PrimOpEqInt
| PrimOpUpdateInt
| PrimOpCopyInt
deriving (Show, Eq, Ord)
instance Pretty PrimOp where
ppr op
= case op of
PrimOpNegInt -> text "negInt"
PrimOpAddInt -> text "addInt"
PrimOpSubInt -> text "subInt"
PrimOpMulInt -> text "mulInt"
PrimOpDivInt -> text "divInt"
PrimOpEqInt -> text "eqInt"
PrimOpUpdateInt -> text "updateInt"
PrimOpCopyInt -> text "copyInt"
readName :: String -> Maybe Name
readName [] = Nothing
readName str@(c:rest)
| isLower c
= case (c:rest) of
"negInt" -> Just $ NamePrimOp PrimOpNegInt
"addInt" -> Just $ NamePrimOp PrimOpAddInt
"subInt" -> Just $ NamePrimOp PrimOpSubInt
"mulInt" -> Just $ NamePrimOp PrimOpMulInt
"divInt" -> Just $ NamePrimOp PrimOpDivInt
"eqInt" -> Just $ NamePrimOp PrimOpEqInt
"updateInt" -> Just $ NamePrimOp PrimOpUpdateInt
"copyInt" -> Just $ NamePrimOp PrimOpCopyInt
_ -> Just $ NameVar str
| str == "Unit" = Just $ NamePrimCon PrimTyConUnit
| str == "()" = Just $ NamePrimCon PrimDaConUnit
| str == "Int" = Just $ NamePrimCon PrimTyConInt
| (ds, "") <- span isDigit str
= Just $ NameInt (read ds)
| str == "Pair" = Just $ NamePrimCon PrimTyConPair
| str == "Pr" = Just $ NamePrimCon PrimDaConPr
| str == "List" = Just $ NamePrimCon PrimTyConList
| str == "Nil" = Just $ NamePrimCon PrimDaConNil
| str == "Cons" = Just $ NamePrimCon PrimDaConCons
| c == 'R'
, (ds, "#") <- span isDigit rest
, not $ null ds
= Just $ NameRgn (Rgn $ read ds)
| c == 'L'
, (ds, "#") <- span isDigit rest
, not $ null ds
= Just $ NameLoc (Loc $ read ds)
| str == "Global#" = Just $ NameCap CapGlobal
| str == "Const#" = Just $ NameCap CapConst
| str == "Mutable#" = Just $ NameCap CapMutable
| str == "Lazy#" = Just $ NameCap CapLazy
| str == "Manifest#" = Just $ NameCap CapManifest
| isUpper c
= Just $ NameCon str
| otherwise
= Nothing
readName_ :: String -> Name
readName_ str
= fromMaybe (error $ "can't rename token " ++ str)
$ readName str
lexString :: Int -> String -> [Token (Tok Name)]
lexString lineStart str
= map rn $ lexExp lineStart str
where rn (Token t sp) = Token (renameTok readName_ t) sp