module DDC.Core.Flow.Prim
        ( -- * Names and lexing
          Name          (..)
        , readName

          -- * Fragment specific kind constructors
        , KiConFlow     (..)
        , readKiConFlow

          -- * Fragment specific type constructors
        , TyConFlow     (..)
        , readTyConFlow
        , kindTyConFlow

          -- * Fragment specific data constructors
        , DaConFlow     (..)
        , readDaConFlow
        , typeDaConFlow

          -- * Fusable Flow operators
        , OpConcrete    (..)
        , readOpConcrete
        , typeOpConcrete

          -- * Series operators
        , OpSeries      (..)
        , readOpSeries
        , typeOpSeries

          -- * Control operators
        , OpControl     (..)
        , readOpControl
        , typeOpControl

          -- * Store operators
        , OpStore       (..)
        , readOpStore
        , typeOpStore

          -- * Store operators
        , OpVector      (..)
        , readOpVector
        , typeOpVector

          -- * Primitive type constructors
        , PrimTyCon     (..)
        , kindPrimTyCon

          -- * Primitive arithmetic operators
        , PrimArith     (..)
        , typePrimArith

          -- * Primitive vector operators
        , PrimVec    (..)
        , typePrimVec
        , multiOfPrimVec
        , liftPrimArithToVec
        , lowerPrimVecToArith

          -- * Casting between primitive types
        , 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.Salt.Name
        ( readPrimTyCon
        
        , readPrimArith
        
        , readPrimVec
        , multiOfPrimVec
        , liftPrimArithToVec
        , lowerPrimVecToArith
        
        , readPrimCast
        , readLitPrimNat
        , readLitPrimInt
        , readLitPrimWordOfBits
        , readLitPrimFloatOfBits)
        
import DDC.Base.Pretty
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 "#"


-- | Read the name of a variable, constructor or literal.
readName :: String -> Maybe Name
readName str
        -- Flow fragment specific names.
        | 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 

        -- Primitive names.
        | 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

        -- Literal Bools
        | str == "True#"  = Just $ NameLitBool True
        | str == "False#" = Just $ NameLitBool False

        -- Literal Nat
        | Just val <- readLitPrimNat str
        = Just $ NameLitNat  val

        -- Literal Ints
        | Just val <- readLitPrimInt str
        = Just $ NameLitInt  val

        -- Literal Words
        | Just (val, bits)      <- readLitPrimWordOfBits str
        , elem bits [8, 16, 32, 64]
        = Just $ NameLitWord val bits

        -- Literal Floats
        | Just (val, bits)      <- readLitPrimFloatOfBits str
        , elem bits [32, 64]
        = Just $ NameLitFloat (toRational val) bits

        -- Variables.
        | c : _                 <- str
        , isLower c
        , Just (str1, strMod)   <- splitModString str
        , Just n                <- readName str1
        = Just $ NameVarMod n strMod

        | c : _         <- str
        , isLower c      
        = Just $ NameVar str

        -- Constructors.
        | c : _         <- str
        , isUpper c
        = Just $ NameCon str

        | otherwise
        = Nothing


-- | Strip a `...$thing` modifier from a name.
splitModString :: String -> Maybe (String, String)
splitModString str
 = case break (== '$') (reverse str) of
        (_, "")         -> Nothing
        ("", _)         -> Nothing
        (s2, _ : s1)    -> Just (reverse s1, reverse s2)