-- 
-- (c) Susumu Katayama
--
{-# OPTIONS -XTemplateHaskell #-}
module MagicHaskeller.Individual(availableNames, prioritizedNamesToPg) where
import Language.Haskell.TH as TH
import qualified Data.Map as M
import qualified Data.IntMap as I
import Data.Char(isDigit)
import Data.List(findIndex, findIndices, mapAccumL, mapAccumR)
import Data.Generics
import MagicHaskeller.LibTH
import MagicHaskeller.Types(size)
import MagicHaskeller.ProgGenSF(mkTrieOptSFIO)
import Prelude hiding (tail)

-- | 'totals' is the set of available values (except partial functions) that can be included/excluded individually.
totals :: [Primitive]
totals :: [Primitive]
totals = [[Primitive]] -> [Primitive]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Primitive]]
withDoubleRatio
-- You can add functions you like here, e.g. 
-- totals = concat withDoubleRatio ++ $(p [| nat_para :: (->) Int (a -> (Int -> a -> a) -> a) |] )

-- | 'partials' is the set of available partial functions that can be included/excluded individually.
partials :: [(Primitive,Primitive)]
partials :: [(Primitive, Primitive)]
partials = [[(Primitive, Primitive)]] -> [(Primitive, Primitive)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Primitive, Primitive)]]
tupartialssNormal -- ++ ....

-- | 'aliases' is the set of aliases that can be used instead of the exact names appearing in 'totals' in order to increase readability of primitive library files. Also, aliases can be used to group a set of primitives and enable at once.
aliases :: [(String, [Primitive])]
aliases :: [(String, [Primitive])]
aliases = [ (String
"total init", $(p [| reverse . drop 1 . reverse :: [a] -> [a] |])),
            (String
"total head", $(p [| foldr const :: a -> (->) [a] a |])),
            (String
"total last", $(p [| last' :: a -> [a] -> a |])),
            (String
"drop 1",     $(p [| tail :: (->) [a] [a] |] )),
            (String
"foldl",      $(p [| flip . flip foldl :: a -> (->) [b] ((a -> b -> a) -> a) |])),
            (String
"foldr",      $(p [| flip . flip foldr :: a -> (->) [b] ((b -> a -> a) -> a) |])),
            (String
"maybe",      $(p [| flip . maybe :: a -> (->) (Maybe b) ((b -> a) -> a) |])),
            (String
"map",        $(p [| flip map :: (->) ([a]) ((a -> b) -> [b]) |])),
            (String
"concatMap",  $(p [| flip concatMap :: (->) ([a]) ((a -> [b]) -> [b]) |])),
            (String
"any",        $(p [| flip any :: (->) ([a]) ((a -> Bool) -> Bool) |])),
            (String
"all",        $(p [| flip all :: (->) ([a]) ((a -> Bool) -> Bool) |])),
            (String
"zipWith",    $(p [| flip . flip zipWith :: (->) ([a]) ((->) ([b]) ((a -> b -> c) -> [c])) |])),
            (String
"either",     $(p [| flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c) |])),
            (String
"uncurry",    $(p [| flip uncurry :: (->) ((a, b)) ((a -> b -> c) -> c) |])),
            (String
"findIndex",  $(p [| flip findIndex :: (->) ([a]) ((a -> Bool) -> Maybe Int) |])),
            (String
"findIndices",$(p [| flip findIndices :: (->) ([a]) ((a -> Bool) -> [Int]) |])),
            (String
"mapAccumL",  $(p [| flip . flip mapAccumL :: acc -> (->) ([x]) ((acc -> x -> (acc, y)) -> (acc, [y])) |])),
            (String
"mapAccumR",  $(p [| flip . flip mapAccumR :: acc -> (->) ([x]) ((acc -> x -> (acc, y)) -> (acc, [y])) |])),
            (String
"\\n x f -> iterate f x !! (n::Int)", $(p [| nat_cata :: (->) Int (a -> (a -> a) -> a) |])),
            (String
"\\n x f -> iterate f x !! (n::Integer)", $(p [| nat_cata :: (->) Integer (a -> (a -> a) -> a) |]))
          ]

-- `normalizeSpaces' removes redundant spaces.
normalizeSpaces :: String -> String
normalizeSpaces = [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

mapAvailables :: M.Map String (Either [Primitive] (Primitive,Primitive))
mapAvailables :: Map String (Either [Primitive] (Primitive, Primitive))
mapAvailables = [(String, Either [Primitive] (Primitive, Primitive))]
-> Map String (Either [Primitive] (Primitive, Primitive))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, Either [Primitive] (Primitive, Primitive))]
assocAvailables
-- When dumping the available names, 'assocAvailables' is used instead of mapAvailables because I guess they should not be sorted
assocAvailables :: [(String, Either [Primitive] (Primitive, Primitive))]
assocAvailables = [ (String -> String
normalizeSpaces String
s, [Primitive] -> Either [Primitive] (Primitive, Primitive)
forall a b. a -> Either a b
Left [Primitive]
prims) | (String
s, [Primitive]
prims) <- [(String, [Primitive])]
aliases ] [(String, Either [Primitive] (Primitive, Primitive))]
-> [(String, Either [Primitive] (Primitive, Primitive))]
-> [(String, Either [Primitive] (Primitive, Primitive))]
forall a. [a] -> [a] -> [a]
++ [ (Primitive -> String
pprintPrim Primitive
prim, [Primitive] -> Either [Primitive] (Primitive, Primitive)
forall a b. a -> Either a b
Left [Primitive
prim]) | Primitive
prim <- [Primitive]
totals ] [(String, Either [Primitive] (Primitive, Primitive))]
-> [(String, Either [Primitive] (Primitive, Primitive))]
-> [(String, Either [Primitive] (Primitive, Primitive))]
forall a. [a] -> [a] -> [a]
++ [ (Primitive -> String
pprintPrim Primitive
prim, (Primitive, Primitive) -> Either [Primitive] (Primitive, Primitive)
forall a b. b -> Either a b
Right (Primitive, Primitive)
tup) | tup :: (Primitive, Primitive)
tup@(Primitive
_,Primitive
prim) <- [(Primitive, Primitive)]
partials ]

availableNames :: [String]
availableNames :: [String]
availableNames = ((String, Either [Primitive] (Primitive, Primitive)) -> String)
-> [(String, Either [Primitive] (Primitive, Primitive))]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Either [Primitive] (Primitive, Primitive)) -> String
forall a b. (a, b) -> a
fst [(String, Either [Primitive] (Primitive, Primitive))]
assocAvailables

-- postprocessを使いたくなるけど，結果同じ表現になっちゃうとまずい．
pprintPrim :: Primitive -> String
pprintPrim :: Primitive -> String
pprintPrim (HValue
_, e :: Exp
e@(VarE Name
name), Type
t) = 
  case Name -> String
nameBase Name
name of 
    (Char
'b':Char
'y':Char
d:Char
'_':String
name) | Char -> Bool
isDigit Char
d -> String
name                            -- Note that the type is omitted, because the class information is lost.
    (Char
'-':Char
'-':Char
'#':String
name)           -> Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:(Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'#') String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"    -- Note that the type is omitted, because the class information is lost.
    String
_                                -> String -> String
normalizeSpaces (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
TH.SigE (Exp -> Exp
simplify Exp
e) Type
t  -- normalizeSpaces is inserted just in case.
pprintPrim (HValue
_, Exp
e, Type
t) = String -> String
normalizeSpaces (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
TH.SigE (Exp -> Exp
simplify Exp
e) Type
t  -- normalizeSpaces is inserted just in case.

simplify :: TH.Exp -> TH.Exp
simplify :: Exp -> Exp
simplify = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Exp -> Exp) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Exp -> Exp
simp)
simp :: Exp -> Exp
simp (ConE Name
name) = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
simp (VarE Name
name) = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
-- We should be careful about removing flips, because that will change the type.
-- simp (AppE (ConE name) e) | nameBase name == "flip" = e
-- simp (AppE (AppE (ConE name1) (ConE name2)) e) | (nameBase name1, nameBase name2) == ("flip",".") = e
simp Exp
e = Exp
e

namesToPrimitives :: [String] -> ([Primitive], [(Primitive,Primitive)])
namesToPrimitives :: [String] -> ([Primitive], [(Primitive, Primitive)])
namesToPrimitives [String]
xss = let ets :: [Either [Primitive] (Primitive, Primitive)]
ets = (String -> Either [Primitive] (Primitive, Primitive))
-> [String] -> [Either [Primitive] (Primitive, Primitive)]
forall a b. (a -> b) -> [a] -> [b]
map ((Map String (Either [Primitive] (Primitive, Primitive))
mapAvailables Map String (Either [Primitive] (Primitive, Primitive))
-> String -> Either [Primitive] (Primitive, Primitive)
forall p. Map String p -> String -> p
!!!) (String -> Either [Primitive] (Primitive, Primitive))
-> (String -> String)
-> String
-> Either [Primitive] (Primitive, Primitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalizeSpaces) [String]
xss
                        in ([ Primitive
prim | Left [Primitive]
prims <- [Either [Primitive] (Primitive, Primitive)]
ets, Primitive
prim <- [Primitive]
prims], [ (Primitive, Primitive)
tup | Right (Primitive, Primitive)
tup <- [Either [Primitive] (Primitive, Primitive)]
ets])


-- a !!! b = M.!
Map String p
a !!! :: Map String p -> String -> p
!!! String
b = case String -> Map String p -> Maybe p
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
b Map String p
a of Maybe p
Nothing -> String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"!!! "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
b
                               Just p
x -> p
x


namessToPrimitives :: [[String]] -> ([[Primitive]], [[(Primitive,Primitive)]])
namessToPrimitives :: [[String]] -> ([[Primitive]], [[(Primitive, Primitive)]])
namessToPrimitives [[String]]
nss = [([Primitive], [(Primitive, Primitive)])]
-> ([[Primitive]], [[(Primitive, Primitive)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Primitive], [(Primitive, Primitive)])]
 -> ([[Primitive]], [[(Primitive, Primitive)]]))
-> [([Primitive], [(Primitive, Primitive)])]
-> ([[Primitive]], [[(Primitive, Primitive)]])
forall a b. (a -> b) -> a -> b
$ ([String] -> ([Primitive], [(Primitive, Primitive)]))
-> [[String]] -> [([Primitive], [(Primitive, Primitive)])]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> ([Primitive], [(Primitive, Primitive)])
namesToPrimitives [[String]]
nss
prioritizedNamesToNamess :: [(Int,String)] -> [[String]]
prioritizedNamesToNamess :: [(Int, String)] -> [[String]]
prioritizedNamesToNamess [(Int, String)]
ts = let mapPriorName :: IntMap [String]
mapPriorName = ([String] -> [String] -> [String])
-> [(Int, [String])] -> IntMap [String]
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
I.fromListWith [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) [(Int
i,[String
s]) | (Int
i,String
s) <- [(Int, String)]
ts]
                              in (Int -> [String]) -> [Int] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> [String] -> ([String] -> [String]) -> Maybe [String] -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [String] -> [String]
forall a. a -> a
id (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> IntMap [String] -> Maybe [String]
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
i IntMap [String]
mapPriorName) [(Int, [String]) -> Int
forall a b. (a, b) -> a
fst ((Int, [String]) -> Int) -> (Int, [String]) -> Int
forall a b. (a -> b) -> a -> b
$ IntMap [String] -> (Int, [String])
forall a. IntMap a -> (Int, a)
I.findMin IntMap [String]
mapPriorName .. (Int, [String]) -> Int
forall a b. (a, b) -> a
fst ((Int, [String]) -> Int) -> (Int, [String]) -> Int
forall a b. (a -> b) -> a -> b
$ IntMap [String] -> (Int, [String])
forall a. IntMap a -> (Int, a)
I.findMax IntMap [String]
mapPriorName]

prioritizedNamesToPg :: Maybe Int -> [(Int,String)] -> IO ProgGenSF
prioritizedNamesToPg :: Maybe Int -> [(Int, String)] -> IO ProgGenSF
prioritizedNamesToPg Maybe Int
Nothing   [(Int, String)]
ts = Opt [[Primitive]] -> [(Int, String)] -> IO ProgGenSF
forall e.
Expression e =>
Opt [[Primitive]] -> [(Int, String)] -> IO (PGSF e)
pNTP Opt [[Primitive]]
forall a. Opt a
options [(Int, String)]
ts
prioritizedNamesToPg (Just Int
sz) [(Int, String)]
ts = Opt [[Primitive]] -> [(Int, String)] -> IO ProgGenSF
forall e.
Expression e =>
Opt [[Primitive]] -> [(Int, String)] -> IO (PGSF e)
pNTP Opt [[Primitive]]
forall a. Opt a
options{memoCondPure :: Type -> Int -> Bool
memoCondPure = \Type
t Int
d -> Type -> Int
size Type
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sz Bool -> Bool -> Bool
&& Int
0Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
d {- && d<7 -}} [(Int, String)]
ts

pNTP :: Opt [[Primitive]] -> [(Int, String)] -> IO (PGSF e)
pNTP Opt [[Primitive]]
opt [(Int, String)]
ts = (Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> IO (PGSF e))
-> Opt [[Primitive]]
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> IO (PGSF e)
forall a.
(Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Opt [[Primitive]]
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
mkPGXOpts Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO (PGSF e)
forall e.
Expression e =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO (PGSF e)
mkTrieOptSFIO Opt [[Primitive]]
opt{tv1 :: Bool
tv1=Bool
True,nrands :: [Int]
nrands=Int -> [Int]
forall a. a -> [a]
repeat Int
20,timeout :: Maybe Int
timeout=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
20000} ([Primitive]
eqs[Primitive] -> [Primitive] -> [Primitive]
forall a. [a] -> [a] -> [a]
++[Primitive]
ords[Primitive] -> [Primitive] -> [Primitive]
forall a. [a] -> [a] -> [a]
++[Primitive]
doubleCls[Primitive] -> [Primitive] -> [Primitive]
forall a. [a] -> [a] -> [a]
++[Primitive]
ratioCls) [(Primitive, Primitive)]
clspartialss [[Primitive]]
tot [[(Primitive, Primitive)]]
part
  where ([[Primitive]]
tot,[[(Primitive, Primitive)]]
part) = [[String]] -> ([[Primitive]], [[(Primitive, Primitive)]])
namessToPrimitives ([[String]] -> ([[Primitive]], [[(Primitive, Primitive)]]))
-> [[String]] -> ([[Primitive]], [[(Primitive, Primitive)]])
forall a b. (a -> b) -> a -> b
$ [(Int, String)] -> [[String]]
prioritizedNamesToNamess [(Int, String)]
ts