module DDC.Core.Salt.Name
( Name (..)
, PrimTyCon (..)
, pprPrimTyConStem
, readPrimTyCon, readPrimTyConStem
, primTyConIsIntegral
, primTyConIsFloating
, primTyConIsUnsigned
, primTyConIsSigned
, primTyConWidth
, PrimVal (..)
, readPrimVal
, pattern NamePrimOp
, pattern NamePrimLit
, PrimOp (..)
, readPrimOp
, PrimArith (..)
, readPrimArith
, PrimCall (..)
, readPrimCall
, PrimCast (..)
, readPrimCast
, primCastPromoteIsValid
, primCastTruncateIsValid
, PrimControl (..)
, readPrimControl
, PrimStore (..)
, readPrimStore
, PrimVec (..)
, readPrimVec
, multiOfPrimVec
, liftPrimArithToVec
, lowerPrimVecToArith
, PrimLit (..)
, readPrimLit
, readLitInteger
, readLitNat
, readLitInt
, readLitSize
, readLitWordOfBits
, readLitFloatOfBits
, pattern NameLitVoid
, pattern NameLitBool
, pattern NameLitNat
, pattern NameLitInt
, pattern NameLitSize
, pattern NameLitWord
, pattern NameLitFloat
, pattern NameLitTextLit
, pattern NameLitTag
, readName
, takeNameVar )
where
import DDC.Core.Salt.Name.PrimArith
import DDC.Core.Salt.Name.PrimCall
import DDC.Core.Salt.Name.PrimCast
import DDC.Core.Salt.Name.PrimControl
import DDC.Core.Salt.Name.PrimStore
import DDC.Core.Salt.Name.PrimTyCon
import DDC.Core.Salt.Name.PrimVec
import DDC.Core.Salt.Name.Lit
import DDC.Core.Lexer.Names (isVarStart)
import DDC.Data.ListUtils
import DDC.Base.Pretty
import DDC.Base.Name
import Data.Typeable
import Data.Char
import Data.List
import Control.DeepSeq
import Data.Text (Text)
import qualified Data.Text as T
data Name
= NameVar !String
| NameCon !String
| NameExt !Name !String
| NameObjTyCon
| NamePrimTyCon !PrimTyCon
| NamePrimVal !PrimVal
deriving (Eq, Ord, Show, Typeable)
instance NFData Name where
rnf name
= case name of
NameVar s -> rnf s
NameExt n s -> rnf n `seq` rnf s
NameCon s -> rnf s
NameObjTyCon -> ()
NamePrimTyCon con -> rnf con
NamePrimVal val -> rnf val
instance Pretty Name where
ppr nn
= case nn of
NameVar n -> text n
NameCon n -> text n
NameExt n ext -> ppr n <> text "$" <> text ext
NameObjTyCon -> text "Obj"
NamePrimTyCon tc -> ppr tc
NamePrimVal val -> ppr val
instance CompoundName Name where
extendName n str
= NameExt n str
splitName nn
= case nn of
NameExt n str -> Just (n, str)
_ -> Nothing
readName :: String -> Maybe Name
readName str
| str == "Obj"
= Just $ NameObjTyCon
| Just p <- readPrimTyCon str
= Just $ NamePrimTyCon p
| Just p <- readPrimVal str
= Just $ NamePrimVal p
| c : _ <- str
, isUpper c
= Just $ NameVar str
| c : _ <- str
, isVarStart c || c == '_'
= Just $ NameVar str
| otherwise
= Nothing
takeNameVar :: Name -> Maybe String
takeNameVar (NameVar n)
= Just n
takeNameVar (NameExt n str)
| Just n' <- takeNameVar n
= Just (n' ++ "$" ++ str)
takeNameVar _
= Nothing
data PrimVal
= PrimValOp !PrimOp
| PrimValLit !PrimLit
deriving (Eq, Ord, Show)
pattern NamePrimOp op = NamePrimVal (PrimValOp op)
pattern NamePrimLit lit = NamePrimVal (PrimValLit lit)
instance NFData PrimVal where
rnf p
= case p of
PrimValOp op -> rnf op
PrimValLit lit -> rnf lit
instance Pretty PrimVal where
ppr p
= case p of
PrimValOp op -> ppr op
PrimValLit lit -> ppr lit
readPrimVal :: String -> Maybe PrimVal
readPrimVal str
| Just op <- readPrimOp str
= Just $ PrimValOp op
| Just lit <- readPrimLit str
= Just $ PrimValLit lit
| otherwise
= Nothing
data PrimOp
= PrimArith !PrimArith
| PrimCast !PrimCast
| PrimStore !PrimStore
| PrimCall !PrimCall
| PrimControl !PrimControl
deriving (Eq, Ord, Show)
instance NFData PrimOp where
rnf op
= case op of
PrimArith pa -> rnf pa
PrimCast pc -> rnf pc
PrimStore ps -> rnf ps
PrimCall pc -> rnf pc
PrimControl pc -> rnf pc
instance Pretty PrimOp where
ppr pp
= case pp of
PrimArith op -> ppr op
PrimCast c -> ppr c
PrimStore p -> ppr p
PrimCall c -> ppr c
PrimControl c -> ppr c
readPrimOp :: String -> Maybe PrimOp
readPrimOp str
| Just p <- readPrimArith str
= Just $ PrimArith p
| Just p <- readPrimCast str
= Just $ PrimCast p
| Just p <- readPrimCall str
= Just $ PrimCall p
| Just p <- readPrimControl str
= Just $ PrimControl p
| Just p <- readPrimStore str
= Just $ PrimStore p
| otherwise
= Nothing
data PrimLit
= PrimLitVoid
| PrimLitBool !Bool
| PrimLitNat !Integer
| PrimLitInt !Integer
| PrimLitSize !Integer
| PrimLitWord !Integer !Int
| PrimLitFloat !Double !Int
| PrimLitTextLit !Text
| PrimLitTag !Integer
deriving (Eq, Ord, Show)
pattern NameLitVoid = NamePrimVal (PrimValLit PrimLitVoid)
pattern NameLitBool x = NamePrimVal (PrimValLit (PrimLitBool x))
pattern NameLitNat x = NamePrimVal (PrimValLit (PrimLitNat x))
pattern NameLitInt x = NamePrimVal (PrimValLit (PrimLitInt x))
pattern NameLitSize x = NamePrimVal (PrimValLit (PrimLitSize x))
pattern NameLitWord x s = NamePrimVal (PrimValLit (PrimLitWord x s))
pattern NameLitFloat x s = NamePrimVal (PrimValLit (PrimLitFloat x s))
pattern NameLitTextLit x = NamePrimVal (PrimValLit (PrimLitTextLit x))
pattern NameLitTag x = NamePrimVal (PrimValLit (PrimLitTag x))
instance NFData PrimLit where
rnf p
= case p of
PrimLitVoid -> ()
PrimLitBool b -> rnf b
PrimLitNat i -> rnf i
PrimLitInt i -> rnf i
PrimLitSize i -> rnf i
PrimLitWord i bits -> rnf i `seq` rnf bits
PrimLitFloat f bits -> rnf f `seq` rnf bits
PrimLitTextLit bs -> rnf bs
PrimLitTag i -> rnf i
instance Pretty PrimLit where
ppr p
= case p of
PrimLitVoid -> text "V#"
PrimLitBool True -> text "True#"
PrimLitBool False -> text "False#"
PrimLitNat i -> integer i <> text "#"
PrimLitInt i -> integer i <> text "i#"
PrimLitSize i -> integer i <> text "s#"
PrimLitWord i bits -> integer i <> text "w" <> int bits <> text "#"
PrimLitFloat f bits -> double f <> text "f" <> int bits <> text "#"
PrimLitTextLit tx -> (text $ show $ T.unpack tx) <> text "#"
PrimLitTag i -> text "TAG" <> integer i <> text "#"
readPrimLit :: String -> Maybe PrimLit
readPrimLit str
| str == "V#"
= Just $ PrimLitVoid
| str == "True#" = Just $ PrimLitBool True
| str == "False#" = Just $ PrimLitBool False
| Just str' <- stripSuffix "#" str
, Just val <- readLitNat str'
= Just $ PrimLitNat val
| Just str' <- stripSuffix "#" str
, Just val <- readLitInt str'
= Just $ PrimLitInt val
| Just str' <- stripSuffix "s#" str
, Just val <- readLitSize str'
= Just $ PrimLitSize val
| Just str' <- stripSuffix "#" str
, Just (val, bits) <- readLitWordOfBits str'
, elem bits [8, 16, 32, 64]
= Just $ PrimLitWord val bits
| Just str' <- stripSuffix "#" str
, Just (val, bits) <- readLitFloatOfBits str'
, elem bits [32, 64]
= Just $ PrimLitFloat val bits
| Just rest <- stripPrefix "TAG" str
, (ds, "#") <- span isDigit rest
= Just $ PrimLitTag (read ds)
| otherwise
= Nothing