module DDC.Core.Flow.Prim
(
Name (..)
, readName
, KiConFlow (..)
, readKiConFlow
, TyConFlow (..)
, readTyConFlow
, kindTyConFlow
, DaConFlow (..)
, readDaConFlow
, typeDaConFlow
, OpConcrete (..)
, readOpConcrete
, typeOpConcrete
, OpSeries (..)
, readOpSeries
, typeOpSeries
, OpControl (..)
, readOpControl
, typeOpControl
, OpStore (..)
, readOpStore
, typeOpStore
, OpVector (..)
, readOpVector
, typeOpVector
, PrimTyCon (..)
, kindPrimTyCon
, PrimArith (..)
, typePrimArith
, PrimVec (..)
, typePrimVec
, multiOfPrimVec
, liftPrimArithToVec
, lowerPrimVecToArith
, PrimCast (..)
, typePrimCast)
where
import DDC.Core.Flow.Prim.Base
import DDC.Core.Flow.Prim.KiConFlow
import DDC.Core.Flow.Prim.TyConFlow
import DDC.Core.Flow.Prim.TyConPrim
import DDC.Core.Flow.Prim.DaConFlow
import DDC.Core.Flow.Prim.DaConPrim ()
import DDC.Core.Flow.Prim.OpConcrete
import DDC.Core.Flow.Prim.OpControl
import DDC.Core.Flow.Prim.OpSeries
import DDC.Core.Flow.Prim.OpStore
import DDC.Core.Flow.Prim.OpVector
import DDC.Core.Flow.Prim.OpPrim
import DDC.Core.Lexer.Names (isVarStart)
import DDC.Core.Salt.Name
( readPrimTyCon
, readPrimArith
, readPrimVec
, multiOfPrimVec
, liftPrimArithToVec
, lowerPrimVecToArith
, readPrimCast
, readLitNat
, readLitInt
, readLitWordOfBits
, readLitFloatOfBits)
import DDC.Base.Pretty
import DDC.Base.Name
import DDC.Data.ListUtils
import Control.DeepSeq
import Data.Char
instance NFData Name where
rnf nn
= case nn of
NameVar s -> rnf s
NameVarMod n s -> rnf n `seq` rnf s
NameCon s -> rnf s
NameKiConFlow con -> rnf con
NameTyConFlow con -> rnf con
NameDaConFlow con -> rnf con
NameOpConcrete op -> rnf op
NameOpControl op -> rnf op
NameOpSeries op -> rnf op
NameOpStore op -> rnf op
NameOpVector op -> rnf op
NamePrimTyCon op -> rnf op
NamePrimArith op -> rnf op
NamePrimVec op -> rnf op
NamePrimCast op -> rnf op
NameLitBool b -> rnf b
NameLitNat n -> rnf n
NameLitInt i -> rnf i
NameLitWord i bits -> rnf i `seq` rnf bits
NameLitFloat r bits -> rnf r `seq` rnf bits
instance Pretty Name where
ppr nn
= case nn of
NameVar s -> text s
NameVarMod n s -> ppr n <> text "$" <> text s
NameCon c -> text c
NameKiConFlow con -> ppr con
NameTyConFlow con -> ppr con
NameDaConFlow con -> ppr con
NameOpConcrete op -> ppr op
NameOpControl op -> ppr op
NameOpSeries op -> ppr op
NameOpStore op -> ppr op
NameOpVector op -> ppr op
NamePrimTyCon tc -> ppr tc
NamePrimArith op -> ppr op
NamePrimVec op -> ppr op
NamePrimCast op -> ppr op
NameLitBool True -> text "True#"
NameLitBool False -> text "False#"
NameLitNat i -> integer i <> text "#"
NameLitInt i -> integer i <> text "i" <> text "#"
NameLitWord i bits -> integer i <> text "w" <> int bits <> text "#"
NameLitFloat r bits -> double (fromRational r) <> text "f" <> int bits <> text "#"
instance CompoundName Name where
extendName n str
= NameVarMod n str
splitName nn
= case nn of
NameVarMod n str -> Just (n, str)
_ -> Nothing
readName :: String -> Maybe Name
readName str
| Just p <- readKiConFlow str = Just $ NameKiConFlow p
| Just p <- readTyConFlow str = Just $ NameTyConFlow p
| Just p <- readDaConFlow str = Just $ NameDaConFlow p
| Just p <- readOpConcrete str = Just $ NameOpConcrete p
| Just p <- readOpControl str = Just $ NameOpControl p
| Just p <- readOpSeries str = Just $ NameOpSeries p
| Just p <- readOpStore str = Just $ NameOpStore p
| Just p <- readOpVector str = Just $ NameOpVector p
| Just p <- readPrimTyCon str = Just $ NamePrimTyCon p
| Just p <- readPrimArith str = Just $ NamePrimArith p
| Just p <- readPrimVec str = Just $ NamePrimVec p
| Just p <- readPrimCast str = Just $ NamePrimCast p
| str == "True#" = Just $ NameLitBool True
| str == "False#" = Just $ NameLitBool False
| Just str' <- stripSuffix "#" str
, Just val <- readLitNat str'
= Just $ NameLitNat val
| Just str' <- stripSuffix "#" str
, Just val <- readLitInt str'
= Just $ NameLitInt val
| Just str' <- stripSuffix "#" str
, Just (val, bits) <- readLitWordOfBits str'
, elem bits [8, 16, 32, 64]
= Just $ NameLitWord val bits
| Just str' <- stripSuffix "#" str
, Just (val, bits) <- readLitFloatOfBits str'
, elem bits [32, 64]
= Just $ NameLitFloat (toRational val) bits
| c : _ <- str
, isVarStart c
, Just (str1, strMod) <- splitModString str
, Just n <- readName str1
= Just $ NameVarMod n strMod
| c : _ <- str
, isVarStart c
= Just $ NameVar str
| c : _ <- str
, isUpper c
= Just $ NameCon str
| otherwise
= Nothing
splitModString :: String -> Maybe (String, String)
splitModString str
= case break (== '$') (reverse str) of
(_, "") -> Nothing
("", _) -> Nothing
(s2, _ : s1) -> Just (reverse s1, reverse s2)