module DDC.Core.Eval.Name
( Name (..)
, PrimCon (..)
, PrimOp (..)
, Loc (..)
, Rgn (..)
, Cap (..)
, readName
, lexModuleString
, lexExpString)
where
import DDC.Core.Lexer
import DDC.Base.Pretty
import DDC.Data.Token
import DDC.Type.Exp
import DDC.Type.Compounds
import Control.DeepSeq
import Data.Typeable
import Data.Char
import Data.List
data Name
= NameVar String
| NameCon String
| NameInt Integer
| NamePrimCon PrimCon
| NamePrimOp PrimOp
| NameLoc Loc
| NameRgn Rgn
| NameCap Cap
deriving (Show, Eq, Ord, Typeable)
instance NFData Name where
rnf nn
= case nn of
NameVar s -> rnf s
NameCon s -> rnf s
NameInt i -> rnf i
NamePrimCon pc -> rnf pc
NamePrimOp po -> rnf po
NameLoc l -> rnf l
NameRgn r -> rnf r
NameCap c -> rnf c
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 (Type Name)
deriving Show
instance NFData Loc where
rnf (Loc i t) = rnf i `seq` rnf t
instance Pretty Loc where
ppr (Loc l _) = text "l" <> text (show l) <> text "#"
instance Eq Loc where
(==) (Loc l1 _) (Loc l2 _)
= l1 == l2
instance Ord Loc where
compare (Loc l1 _) (Loc l2 _)
= compare l1 l2
data Rgn
= Rgn Int
deriving (Eq, Ord, Show)
instance NFData Rgn where
rnf (Rgn i) = rnf i
instance Pretty Rgn where
ppr (Rgn r) = text "r" <> text (show r) <> text "#"
data Cap
= CapGlobal
| CapConst
| CapMutable
| CapDistinct Int
| CapLazy
| CapManifest
deriving (Eq, Ord, Show)
instance NFData Cap where
rnf cap
= case cap of
CapDistinct i -> rnf i
_ -> ()
instance Pretty Cap where
ppr cp
= case cp of
CapGlobal -> text "Global#"
CapConst -> text "Const#"
CapMutable -> text "Mutable#"
CapDistinct n -> text "Distinct" <> ppr n <> text "#"
CapLazy -> text "Lazy#"
CapManifest -> text "Manifest#"
data PrimCon
= PrimTyConInt
| PrimTyConPair
| PrimTyConList
| PrimDaConPr
| PrimDaConNil
| PrimDaConCons
deriving (Show, Eq, Ord)
instance NFData PrimCon
instance Pretty PrimCon where
ppr con
= case con of
PrimTyConInt -> text "Int"
PrimTyConPair -> text "Pair"
PrimTyConList -> text "List"
PrimDaConPr -> text "Pr"
PrimDaConNil -> text "Nil"
PrimDaConCons -> text "Cons"
data PrimOp
= PrimOpNegInt
| PrimOpAddInt
| PrimOpSubInt
| PrimOpMulInt
| PrimOpDivInt
| PrimOpEqInt
| PrimOpUpdateInt
| PrimOpCopyInt
deriving (Show, Eq, Ord)
instance NFData PrimOp
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)
| 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) (tBot kData))
| 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 == "Int" = Just $ NamePrimCon PrimTyConInt
| c == '-'
, all isDigit rest
= Just $ NameInt (read str)
| all isDigit str
= Just $ NameInt (read str)
| 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
| 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
| Just n <- stripPrefix "Distinct" str
, n' <- read $ takeWhile ('#' /=) n
= Just $ NameCap (CapDistinct n')
| isUpper c
= Just $ NameCon str
| otherwise
= Nothing
lexModuleString :: String -> Int -> String -> [Token (Tok Name)]
lexModuleString sourceName lineStart str
= map rn $ lexModuleWithOffside sourceName lineStart str
where rn (Token strTok sp)
= case renameTok readName strTok of
Just t' -> Token t' sp
Nothing -> Token (KJunk "lexical error") sp
lexExpString :: String -> Int -> String -> [Token (Tok Name)]
lexExpString sourceName lineStart str
= map rn $ lexExp sourceName lineStart str
where rn (Token strTok sp)
= case renameTok readName strTok of
Just t' -> Token t' sp
Nothing -> Token (KJunk "lexical error") sp