module Feldspar.Core.Frontend
( module Data.Patch
, Syntactic
, SyntacticFeld
, Internal
, FeldDomainAll
, Data
, Syntax
, module Frontend
, reifyFeld
, showExpr
, printExpr
, showAST
, drawAST
, showDecor
, drawDecor
, eval
, evalTarget
, desugar
, sugar
, resugar
, (===>)
, (===)
, tData
, tArr1
, tArr2
, tM
, ilog2
, nlz
) where
import Prelude as P
import Control.Monad.State
import Test.QuickCheck
import Data.Patch
import Data.Typeable
import Language.Syntactic hiding
(desugar, sugar, resugar, printExpr, showAST, drawAST)
import qualified Language.Syntactic as Syntactic
import qualified Language.Syntactic.Constructs.Decoration as Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Language.Syntactic.Sharing.SimpleCodeMotion
import Feldspar.Range
import Feldspar.Core.Types
import Feldspar.Core.Interpretation hiding (showDecor, drawDecor)
import Feldspar.Core.Constructs
import Feldspar.Core.Constructs.Binding (cLambda)
import Feldspar.Core.Frontend.Array as Frontend
import Feldspar.Core.Frontend.Binding as Frontend
import Feldspar.Core.Frontend.Bits as Frontend
import Feldspar.Core.Frontend.Complex as Frontend
import Feldspar.Core.Frontend.Condition as Frontend
import Feldspar.Core.Frontend.ConditionM as Frontend
import Feldspar.Core.Frontend.Conversion as Frontend
import Feldspar.Core.Frontend.Eq as Frontend
import Feldspar.Core.Frontend.Error as Frontend
import Feldspar.Core.Frontend.FFI as Frontend
import Feldspar.Core.Frontend.Floating as Frontend
import Feldspar.Core.Frontend.Fractional as Frontend
import Feldspar.Core.Frontend.Future as Frontend
import Feldspar.Core.Frontend.Integral as Frontend
import Feldspar.Core.Frontend.Literal as Frontend
import Feldspar.Core.Frontend.Logic as Frontend
import Feldspar.Core.Frontend.Loop as Frontend
import Feldspar.Core.Frontend.Mutable as Frontend
import Feldspar.Core.Frontend.MutableArray as Frontend
import Feldspar.Core.Frontend.MutableReference as Frontend
import Feldspar.Core.Frontend.MutableToPure as Frontend
import Feldspar.Core.Frontend.NoInline as Frontend
import Feldspar.Core.Frontend.Num as Frontend
import Feldspar.Core.Frontend.Ord as Frontend
import Feldspar.Core.Frontend.Par as Frontend
import Feldspar.Core.Frontend.Save as Frontend
import Feldspar.Core.Frontend.Select as Frontend
import Feldspar.Core.Frontend.SizeProp as Frontend
import Feldspar.Core.Frontend.SourceInfo as Frontend
import Feldspar.Core.Frontend.Trace as Frontend
import Feldspar.Core.Frontend.Tuple as Frontend
prjDict :: PrjDict (Decor Info FeldDomain)
prjDict = PrjDict
(prjVariable prjDictFO . decorExpr)
(prjLambda prjDictFO . decorExpr)
mkId :: MkInjDict (Decor Info FeldDomain)
mkId a b | simpleMatch (const . sharable) a
, Just Dict <- typeDict b
, Just Dict <- typeDict a
= Just InjDict
{ injVariable = Decor (getInfo a) . injC . c' . Variable
, injLambda = let info = ((mkInfoTy (FunType typeRep typeRep)) { infoSize = infoSize (getInfo b)})
in Decor info . injC . cLambda
, injLet = Decor (getInfo b) $ injC $ c' Let
}
mkId _ _ = Nothing
type SyntacticFeld a = (Syntactic a, Domain a ~ FeldDomainAll, Typeable (Internal a))
reifyFeld :: SyntacticFeld a
=> BitWidth n
-> a
-> ASTF (Decor Info FeldDomain) (Internal a)
reifyFeld n = flip evalState 0 .
( return
<=< codeMotion prjDict mkId
. optimize
. targetSpecialization n
<=< reifyM
. Syntactic.desugar
)
showExpr :: SyntacticFeld a => a -> String
showExpr = render . reifyFeld N32
printExpr :: SyntacticFeld a => a -> IO ()
printExpr = Syntactic.printExpr . reifyFeld N32
showAST :: SyntacticFeld a => a -> String
showAST = Syntactic.showAST . reifyFeld N32
drawAST :: SyntacticFeld a => a -> IO ()
drawAST = Syntactic.drawAST . reifyFeld N32
showDecor :: SyntacticFeld a => a -> String
showDecor = Syntactic.showDecor . reifyFeld N32
drawDecor :: SyntacticFeld a => a -> IO ()
drawDecor = Syntactic.drawDecor . reifyFeld N32
eval :: SyntacticFeld a => a -> Internal a
eval = evalBind . reifyFeld N32
evalTarget
:: ( SyntacticFeld a
, BoundedInt (GenericInt U n)
, BoundedInt (GenericInt S n)
)
=> BitWidth n -> a -> Internal a
evalTarget n = evalBind . reifyFeld n
desugar :: Syntax a => a -> Data (Internal a)
desugar = Syntactic.resugar
sugar :: Syntax a => Data (Internal a) -> a
sugar = Syntactic.resugar
resugar :: (Syntax a, Syntax b, Internal a ~ Internal b) => a -> b
resugar = Syntactic.resugar
instance (Type a, Arbitrary a) => Arbitrary (Data a)
where
arbitrary = fmap value arbitrary
instance Testable (Data Bool)
where
property = property . eval
(===>) :: Testable prop => Data Bool -> prop -> Property
a ===> b = eval a ==> b
class Equal a
where
(===) :: a -> a -> Property
instance (P.Eq a, Show a) => Equal a
where
x === y = printTestCase ("Evaluated property: " ++ show x ++ " === " ++ show y)
$ property (x P.== y)
instance (Show a, Arbitrary a, Equal b) => Equal (a -> b)
where
f === g = property (\x -> f x === g x)
tData :: Patch a a -> Patch (Data a) (Data a)
tData _ = id
tArr1 :: Patch a a -> Patch (Data [a]) (Data [a])
tArr1 _ = id
tArr2 :: Patch a a -> Patch (Data [[a]]) (Data [[a]])
tArr2 _ = id
tM :: Patch a a -> Patch (M a) (M a)
tM _ = id
ilog2 :: (Bits a) => Data a -> Data Index
ilog2 x = bitSize x 1 nlz x
nlz :: (Bits a) => Data a -> Data Index
nlz x = bitCount $ complement $ foldl go x $ takeWhile (P.< bitSize' x) $ P.map (2 P.^) [(0::Integer)..]
where
go b s = b .|. (b .>>. value s)