{-# LANGUAGE ParallelListComp #-} module Main where import Text.PrettyPrint import System.Environment ( getArgs ) main = do [s] <- getArgs let n = read s mapM_ (putStrLn . render . generate) [2..n] generate :: Int -> Doc generate n = vcat [ text "#ifdef DEFINE_INSTANCES" , data_instance "MVector s" "MV" , data_instance "Vector" "V" , class_instance "Unbox" , class_instance "M.MVector MVector" <+> text "where" , nest 2 $ vcat $ map method methods_MVector , class_instance "G.Vector Vector" <+> text "where" , nest 2 $ vcat $ map method methods_Vector , text "#endif" , text "#ifdef DEFINE_MUTABLE" , define_zip "MVector s" "MV" , define_unzip "MVector s" "MV" , text "#endif" , text "#ifdef DEFINE_IMMUTABLE" , define_zip "Vector" "V" , define_zip_rule , define_unzip "Vector" "V" , text "#endif" ] where vars = map char $ take n ['a'..] varss = map (<> char 's') vars tuple xs = parens $ hsep $ punctuate comma xs vtuple xs = parens $ sep $ punctuate comma xs con s = text s <> char '_' <> int n var c = text (c : "_") data_instance ty c = hang (hsep [text "data instance", text ty, tuple vars]) 4 (hsep [char '=', con c, text "{-# UNPACK #-} !Int" , vcat $ map (\v -> char '!' <> parens (text ty <+> v)) vars]) class_instance cls = text "instance" <+> vtuple [text "Unbox" <+> v | v <- vars] <+> text "=>" <+> text cls <+> tuple vars define_zip ty c = sep [text "-- | /O(1)/ Zip" <+> int n <+> text "vectors" ,name <+> text "::" <+> vtuple [text "Unbox" <+> v | v <- vars] <+> text "=>" <+> sep (punctuate (text " ->") [text ty <+> v | v <- vars]) <+> text "->" <+> text ty <+> tuple vars ,text "{-# INLINE_STREAM" <+> name <+> text "#-}" ,name <+> sep varss <+> text "=" <+> con c <+> text "len" <+> sep [parens $ text "unsafeSlice" <+> char '0' <+> text "len" <+> vs | vs <- varss] ,nest 2 $ hang (text "where") 2 $ text "len =" <+> sep (punctuate (text " `delayed_min`") [text "length" <+> vs | vs <- varss]) ] where name | n == 2 = text "zip" | otherwise = text "zip" <> int n define_zip_rule = hang (text "{-# RULES" <+> text "\"stream/" <> name "zip" <> text " [Vector.Unboxed]\" forall" <+> sep varss <+> char '.') 2 $ text "G.stream" <+> parens (name "zip" <+> sep varss) <+> char '=' <+> text "Stream." <> name "zipWith" <+> tuple (replicate n empty) <+> sep [parens $ text "G.stream" <+> vs | vs <- varss] $$ text "#-}" where name s | n == 2 = text s | otherwise = text s <> int n define_unzip ty c = sep [text "-- | /O(1)/ Unzip" <+> int n <+> text "vectors" ,name <+> text "::" <+> vtuple [text "Unbox" <+> v | v <- vars] <+> text "=>" <+> text ty <+> tuple vars <+> text "->" <+> vtuple [text ty <+> v | v <- vars] ,text "{-# INLINE" <+> name <+> text "#-}" ,name <+> pat c <+> text "=" <+> vtuple varss ] where name | n == 2 = text "unzip" | otherwise = text "unzip" <> int n pat c = parens $ con c <+> var 'n' <+> sep varss patn c n = parens $ con c <+> (var 'n' <> int n) <+> sep [v <> int n | v <- varss] qM s = text "M." <> text s qG s = text "G." <> text s gen_length c _ = (pat c, var 'n') gen_unsafeSlice mod c rec = (var 'i' <+> var 'm' <+> pat c, con c <+> var 'm' <+> vcat [parens $ text mod <> char '.' <> text rec <+> var 'i' <+> var 'm' <+> vs | vs <- varss]) gen_overlaps rec = (patn "MV" 1 <+> patn "MV" 2, vcat $ r : [text "||" <+> r | r <- rs]) where r : rs = [qM rec <+> v <> char '1' <+> v <> char '2' | v <- varss] gen_unsafeNew rec = (var 'n', mk_do [v <+> text "<-" <+> qM rec <+> var 'n' | v <- varss] $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss) gen_unsafeReplicate rec = (var 'n' <+> tuple vars, mk_do [vs <+> text "<-" <+> qM rec <+> var 'n' <+> v | v <- vars | vs <- varss] $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss) gen_unsafeRead rec = (pat "MV" <+> var 'i', mk_do [v <+> text "<-" <+> qM rec <+> vs <+> var 'i' | v <- vars | vs <- varss] $ text "return" <+> tuple vars) gen_unsafeWrite rec = (pat "MV" <+> var 'i' <+> tuple vars, mk_do [qM rec <+> vs <+> var 'i' <+> v | v <- vars | vs <- varss] empty) gen_clear rec = (pat "MV", mk_do [qM rec <+> vs | vs <- varss] empty) gen_set rec = (pat "MV" <+> tuple vars, mk_do [qM rec <+> vs <+> v | vs <- varss | v <- vars] empty) gen_unsafeCopy c q rec = (patn "MV" 1 <+> patn c 2, mk_do [q rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss] empty) gen_unsafeMove rec = (patn "MV" 1 <+> patn "MV" 2, mk_do [qM rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss] empty) gen_unsafeGrow rec = (pat "MV" <+> var 'm', mk_do [vs <> char '\'' <+> text "<-" <+> qM rec <+> vs <+> var 'm' | vs <- varss] $ text "return $" <+> con "MV" <+> parens (var 'm' <> char '+' <> var 'n') <+> sep (map (<> char '\'') varss)) gen_unsafeFreeze rec = (pat "MV", mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss] $ text "return $" <+> con "V" <+> var 'n' <+> sep [vs <> char '\'' | vs <- varss]) gen_unsafeThaw rec = (pat "V", mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss] $ text "return $" <+> con "MV" <+> var 'n' <+> sep [vs <> char '\'' | vs <- varss]) gen_basicUnsafeIndexM rec = (pat "V" <+> var 'i', mk_do [v <+> text "<-" <+> qG rec <+> vs <+> var 'i' | vs <- varss | v <- vars] $ text "return" <+> tuple vars) gen_elemseq rec = (char '_' <+> tuple vars, vcat $ r : [char '.' <+> r | r <- rs]) where r : rs = [qG rec <+> parens (text "undefined :: Vector" <+> v) <+> v | v <- vars] mk_do cmds ret = hang (text "do") 2 $ vcat $ cmds ++ [ret] method (s, f) = case f s of (p,e) -> text "{-# INLINE" <+> text s <+> text " #-}" $$ hang (text s <+> p) 4 (char '=' <+> e) methods_MVector = [("basicLength", gen_length "MV") ,("basicUnsafeSlice", gen_unsafeSlice "M" "MV") ,("basicOverlaps", gen_overlaps) ,("basicUnsafeNew", gen_unsafeNew) ,("basicUnsafeReplicate", gen_unsafeReplicate) ,("basicUnsafeRead", gen_unsafeRead) ,("basicUnsafeWrite", gen_unsafeWrite) ,("basicClear", gen_clear) ,("basicSet", gen_set) ,("basicUnsafeCopy", gen_unsafeCopy "MV" qM) ,("basicUnsafeMove", gen_unsafeMove) ,("basicUnsafeGrow", gen_unsafeGrow)] methods_Vector = [("basicUnsafeFreeze", gen_unsafeFreeze) ,("basicUnsafeThaw", gen_unsafeThaw) ,("basicLength", gen_length "V") ,("basicUnsafeSlice", gen_unsafeSlice "G" "V") ,("basicUnsafeIndexM", gen_basicUnsafeIndexM) ,("basicUnsafeCopy", gen_unsafeCopy "V" qG) ,("elemseq", gen_elemseq)]