{-# LANGUAGE TypeFamilies, ExistentialQuantification, FlexibleInstances, UndecidableInstances, FlexibleContexts, DeriveDataTypeable,
ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies,ParallelListComp, TypeSynonymInstances, TypeOperators #-}
module Language.KansasLava.Rep.Class where
import Language.KansasLava.Types
import Control.Monad (liftM)
import Data.Sized.Ix
import qualified Data.Map as Map
class Rep w where
type W w
data X w
unX :: X w -> Maybe w
optX :: Maybe w -> X w
toRep :: X w -> RepValue
fromRep :: RepValue -> X w
repType :: Witness w -> Type
showRep :: X w -> String
showRep x = showRepValue (repType (Witness :: Witness w)) (toRep x)
class (Size (W a), Eq a, Rep a) => BitRep a where
bitRep :: [(a, BitPat (W a))]
allReps :: (Rep w) => Witness w -> [RepValue]
allReps w = [ RepValue (fmap Just count) | count <- counts n ]
where
n = repWidth w
counts :: Int -> [[Bool]]
counts 0 = [[]]
counts num = [ x : xs | xs <- counts (num-1), x <- [False,True] ]
repWidth :: (Rep w) => Witness w -> Int
repWidth w = typeWidth (repType w)
unknownRepValue :: (Rep w) => Witness w -> RepValue
unknownRepValue w = RepValue [ Nothing | _ <- [1..repWidth w]]
pureX :: (Rep w) => w -> X w
pureX = optX . Just
unknownX :: forall w . (Rep w) => X w
unknownX = optX (Nothing :: Maybe w)
liftX :: (Rep a, Rep b) => (a -> b) -> X a -> X b
liftX f = optX . liftM f . unX
showRepDefault :: forall w. (Show w, Rep w) => X w -> String
showRepDefault v = case unX v :: Maybe w of
Nothing -> "?"
Just v' -> show v'
toRepFromIntegral :: forall v . (Rep v, Integral v) => X v -> RepValue
toRepFromIntegral v = case unX v :: Maybe v of
Nothing -> unknownRepValue (Witness :: Witness v)
Just v' -> RepValue
$ take (repWidth (Witness :: Witness v))
$ map (Just . odd)
$ iterate (`div` (2::Integer))
$ fromIntegral v'
fromRepToIntegral :: forall v . (Rep v, Integral v) => RepValue -> X v
fromRepToIntegral r =
optX (fmap (\ xs ->
sum [ n
| (n,b) <- zip (iterate (* 2) 1)
xs
, b
])
(getValidRepValue r) :: Maybe v)
fromRepToInteger :: RepValue -> Integer
fromRepToInteger (RepValue xs) =
sum [ n
| (n,b) <- zip (iterate (* 2) 1)
xs
, case b of
Nothing -> False
Just True -> True
Just False -> False
]
cmpRep :: (Rep a) => X a -> X a -> Bool
cmpRep g v = toRep g `cmpRepValue` toRep v
bitRepEnum :: (Rep a, Enum a, Bounded a, Size (W a)) => [(a,BitPat (W a))]
bitRepEnum = map (\ a -> (a,fromIntegral (fromEnum a))) [minBound .. maxBound]
{-# INLINE bitRepToRep #-}
bitRepToRep :: forall w . (BitRep w, Ord w) => X w -> RepValue
bitRepToRep = bitRepToRep' (Map.fromList $ map (\(a,b) -> (b,a)) $ Map.toList bitRepMap)
bitRepToRep' :: forall w . (BitRep w, Ord w) => Map.Map w RepValue -> X w -> RepValue
bitRepToRep' mp w =
case unX w of
Nothing -> unknownRepValue (Witness :: Witness w)
Just val ->
case Map.lookup val mp of
Nothing -> unknownRepValue (Witness :: Witness w)
Just pat -> pat
{-# INLINE bitRepFromRep #-}
bitRepFromRep :: forall w . (Ord w, BitRep w) => RepValue -> X w
bitRepFromRep = bitRepFromRep' bitRepMap
bitRepFromRep' :: forall w . (Ord w, BitRep w) => Map.Map RepValue w -> RepValue -> X w
bitRepFromRep' mp rep = optX $ Map.lookup rep mp
bitRepMap :: forall w . (BitRep w, Ord w) => Map.Map RepValue w
bitRepMap = Map.fromList
[ (rep,a)
| (a,BitPat repX) <- bitRep
, rep <- expandBitRep repX
]
expandBitRep :: RepValue -> [RepValue]
expandBitRep (RepValue bs) = map RepValue $ expand bs
where
expand [] = [[]]
expand (x:xs) = [ (Just y:ys)
| ys <- expand xs
, y <- case x of
Nothing -> [False,True]
Just v -> [v]
]