module DDC.Source.Tetra.Prim
(
Name (..)
, PrimName (..)
, pattern NameType
, pattern NameVal
, readName
, PrimType (..)
, pattern NameTyCon
, pattern NameTyConTetra
, PrimTyCon (..)
, kindPrimTyCon
, tBool
, tNat
, tInt
, tSize
, tWord
, tFloat
, tTextLit
, PrimTyConTetra(..)
, pattern NameTyConTetraTuple
, pattern NameTyConTetraF
, pattern NameTyConTetraC
, pattern NameTyConTetraU
, kindPrimTyConTetra
, PrimVal (..)
, pattern NameLit
, pattern NameArith
, pattern NameVector
, pattern NameFun
, pattern NameError
, PrimArith (..)
, typePrimArith
, OpVector (..)
, typeOpVector
, OpFun (..)
, typeOpFun
, OpError (..)
, typeOpError
, PrimLit (..)
, pattern NameLitBool
, pattern NameLitNat
, pattern NameLitInt
, pattern NameLitSize
, pattern NameLitWord
, pattern NameLitFloat
, pattern NameLitTextLit)
where
import DDC.Source.Tetra.Prim.Base
import DDC.Source.Tetra.Prim.TyConPrim
import DDC.Source.Tetra.Prim.TyConTetra
import DDC.Source.Tetra.Prim.OpArith
import DDC.Source.Tetra.Prim.OpFun
import DDC.Source.Tetra.Prim.OpVector
import DDC.Source.Tetra.Prim.OpError
import DDC.Core.Lexer.Names (isVarStart)
import DDC.Base.Pretty
import Control.DeepSeq
import Data.Char
import qualified Data.Text as T
import DDC.Core.Tetra
( readPrimTyCon
, readPrimArithFlag
, readOpFun
, readOpErrorFlag
, readOpVectorFlag)
import DDC.Core.Salt.Name
( readLitNat
, readLitInt
, readLitSize
, readLitWordOfBits
, readLitFloatOfBits)
instance Pretty Name where
ppr nn
= case nn of
NameVar v -> text v
NameCon c -> text c
NamePrim p -> ppr p
NameHole -> text "?"
instance NFData Name where
rnf nn
= case nn of
NameVar s -> rnf s
NameCon s -> rnf s
NamePrim p -> rnf p
NameHole -> ()
readName :: String -> Maybe Name
readName str
| Just n <- readPrimName str
= Just $ NamePrim n
| c : _ <- str
, isUpper c
= Just $ NameCon str
| c : _ <- str
, isVarStart c
= Just $ NameVar str
| otherwise
= Nothing
instance Pretty PrimName where
ppr nn
= case nn of
PrimNameType p -> ppr p
PrimNameVal p -> ppr p
instance NFData PrimName where
rnf nn
= case nn of
PrimNameType p -> rnf p
PrimNameVal p -> rnf p
readPrimName :: String -> Maybe PrimName
readPrimName str
| Just t <- readPrimType str
= Just $ PrimNameType t
| Just v <- readPrimVal str
= Just $ PrimNameVal v
| otherwise
= Nothing
instance Pretty PrimType where
ppr t
= case t of
PrimTypeTyConTetra p -> ppr p
PrimTypeTyCon p -> ppr p
instance NFData PrimType where
rnf t
= case t of
PrimTypeTyConTetra p -> rnf p
PrimTypeTyCon p -> rnf p
readPrimType :: String -> Maybe PrimType
readPrimType str
| Just p <- readPrimTyConTetra str
= Just $ PrimTypeTyConTetra p
| Just p <- readPrimTyCon str
= Just $ PrimTypeTyCon p
| otherwise
= Nothing
instance Pretty PrimVal where
ppr val
= case val of
PrimValError p -> ppr p
PrimValLit lit -> ppr lit
PrimValArith p -> ppr p
PrimValVector p -> ppr p
PrimValFun p -> ppr p
instance NFData PrimVal where
rnf val
= case val of
PrimValError p -> rnf p
PrimValLit lit -> rnf lit
PrimValArith p -> rnf p
PrimValVector p -> rnf p
PrimValFun p -> rnf p
readPrimVal :: String -> Maybe PrimVal
readPrimVal str
| Just (p, False) <- readOpErrorFlag str
= Just $ PrimValError p
| Just lit <- readPrimLit str
= Just $ PrimValLit lit
| Just (p, False) <- readPrimArithFlag str
= Just $ PrimValArith p
| Just (p, False) <- readOpVectorFlag str
= Just $ PrimValVector p
| Just p <- readOpFun str
= Just $ PrimValFun p
| otherwise
= Nothing
instance Pretty PrimLit where
ppr lit
= case lit of
PrimLitBool True -> text "True"
PrimLitBool False -> text "False"
PrimLitNat i -> integer i
PrimLitInt i -> integer i <> text "i"
PrimLitSize s -> integer s <> text "s"
PrimLitWord i bits -> integer i <> text "w" <> int bits
PrimLitFloat f bits -> double f <> text "f" <> int bits
PrimLitTextLit tx -> text (show $ T.unpack tx)
instance NFData PrimLit where
rnf lit
= case lit of
PrimLitBool b -> rnf b
PrimLitNat n -> rnf n
PrimLitInt i -> rnf i
PrimLitSize s -> rnf s
PrimLitWord i bits -> rnf i `seq` rnf bits
PrimLitFloat d bits -> rnf d `seq` rnf bits
PrimLitTextLit bs -> rnf bs
readPrimLit :: String -> Maybe PrimLit
readPrimLit str
| str == "True" = Just $ PrimLitBool True
| str == "False" = Just $ PrimLitBool False
| Just val <- readLitNat str
= Just $ PrimLitNat val
| Just val <- readLitInt str
= Just $ PrimLitInt val
| Just val <- readLitSize str
= Just $ PrimLitSize val
| Just (val, bits) <- readLitWordOfBits str
, elem bits [8, 16, 32, 64]
= Just $ PrimLitWord val bits
| Just (val, bits) <- readLitFloatOfBits str
, elem bits [32, 64]
= Just $ PrimLitFloat val bits
| otherwise
= Nothing